Перейти к содержанию

Книга программиста/Задачи на PascalABC.Net

Добавить ссылки
Материал из Викиучебника — открытых книг для открытого мира

К оглавлению | Назад | Вперёд

Все программы, код которых выложен здесь, являются работоспособными. На момент написания программ использовалась среда PascalABC.Net 3.0.

Простые задачи

[править]

Обработка множеств

[править]

Пересечение множеств

[править]
begin
  var A := new SortedSet<integer>(Range(5, 25));
  var B := new SortedSet<integer>(Range(17, 34));
  var C := new SortedSet<integer>(Range(1, 20));
  A.IntersectWith(B);
  A.IntersectWith(C);
  Writeln(A);
end.


var 

 Multiplicity: set of integer;

begin 

 for var i := 1 to ReadlnInteger('Count:') do
   Include(Multiplicity, ReadlnInteger());
 
 Writeln(Multiplicity);
 
 var Count := 0;
 foreach var c in Multiplicity do
   if c < 0 then Inc(Count);
 
 WritelnFormat('Количество отрицательных чисел равно {0}.', Count);

end. </syntaxhighlight> 

begin
  WritelnFormat('Количество отрицательных элементов равно {0}.', ReadArrInteger(ReadlnInteger('N:')).ToSortedSet().Where(x -> x < 0).Count());
end.

Сортировки

[править]

Сортировка пузырьком

[править]
begin
  var N := ReadlnInteger('Размер массива:');
  var A := ReadArrInteger(N);
  var IsSwapped := false;
  
  for var j := N - 1 downto 0 do
  begin
    IsSwapped := false;
    for var i := 0 to j - 1 do
      if A[i] < A[i + 1] then
      begin
        Swap(A[i], A[i + 1]);
        IsSwapped := true;
      end;
    if IsSwapped = false then break;
  end;
  Writeln(A);
end.

Шейкерная сортировка

[править]
Описание алгоритма
  1. Переместить минимум в левый край сортируемой части массива, максимум - в правый.
  2. Уменьшить размер сортируемой части массива.
  3. Вернуться к шагу 1.
const
  N = 4;

var
  A: array [0..N - 1] of integer; 
  Left, Right: integer;

begin
  for var i := 0 to N - 1 do A[i] := Random(100); 
  
  Left := 0; 
  Right := N - 1; 
  while Left < Right do 
  begin
    for var i := Right downto Left + 1 do 
      if A[i - 1] > A[i] then Swap(A[i - 1], A[i]); 
    for var i := Left + 1 to Right - 1 do 
      if A[i] > A[i + 1] then Swap(A[i], A[i + 1]);
    Dec(Right); 
    Inc(Left); 
  end;
  
  Writeln(A); 
end.

Смотрите также: реализация на Python.

Сортировка элементов, удовлетворяющих условию

[править]
begin
  var A := Arr(1, 4, 6, 1, 9, 3);
  var Indexes := new List<integer>();
  
  for var i := 0 to A.Length - 1 do
    if A[i] mod 3 = 0 then
      Indexes.Add(i);
  
  for var i := 0 to Indexes.Count - 1 do
    for var j := i + 1 to Indexes.Count - 1 do
      if A[Indexes[i]] > A[Indexes[j]] then
        Swap(A[Indexes[i]], A[Indexes[j]]);
  
  Writeln(A);
end.

Обработка массивов

[править]

Полные квадраты

[править]
const
  N = 5;

var
  A: array [0..N - 1] of integer;

function IsSquare(x: integer): boolean;
begin
  var y := 1;
  while Sqr(y) < x do
    Inc(y);
  Result := Sqr(y) = x;
end;

begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  for var i := 0 to N - 1 do
    if IsSquare(A[i]) then Write(A[i]:5);
  Writeln();
end.

Поменять местами максимальный и первый элементы

[править]
const
  N = 10;

var
  A: array [0..N - 1] of integer;
  Max: integer := integer.MinValue;
  MaxI: integer;

procedure Print();
begin
  for var i := 0 to N - 1 do
    Write(A[i]:5);
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
  begin
    Readln(A[i]);
    if A[i] > Max then
    begin
      Max := A[i];
      MaxI := i;
    end;
  end;
  
  Print();
  Swap(A[0], A[MaxI]);
  Print();
end.

const
  N = 10;
 
var
  A: array [0..N - 1] of integer;
  MaxI: integer = -1;
 
procedure Print();
begin
  for var i := 0 to N - 1 do
    Write(A[i]:5);
  Writeln();
end;
 
begin
  for var i := 0 to N - 1 do
  begin
    Readln(A[i]);
    if (MaxI = -1) or (A[i] > A[MaxI]) then MaxI := i;
  end;
  
  Print();
  Swap(A[0], A[MaxI]);
  Print();
end.

Вставить число перед нечётными элементами

[править]
const
  N = 10;

type
  IntArray = array of integer;

var
  A: IntArray;
  Count: integer;

procedure Print();
begin
  for var i := 0 to A.Length - 1 do
    Write(A[i]:5);
  Writeln();
end;

begin
  SetLength(A, N);
  for var i := 0 to N - 1 do
  begin
    Readln(A[i]);
    Inc(Count, A[i] mod 2);
  end;
  SetLength(A, N + Count);
  
  Print();
  var i := N - 1;
  var j := N + Count - 1;
  while i >= 0 do
  begin
    A[j] := A[i];
    if A[i] mod 2 <> 0 then
    begin
      A[j - 1] := 400;
      Dec(j);
    end;
    Dec(i);Dec(j);
  end;
  Print();
end.

Сдвиг элементов массива

[править]

Сдвинуть элементы массива, который состоит из 4-х элементов так, чтобы из: a b c d получилось b c d a. 

const
  N = 4;

var
  A: array [0..N] of integer;

procedure Print(s: string);
begin
  Writeln(s);
  for var i := 0 to N - 1 do
    Write(A[i]);
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  Print('Изначальный массив:');
  
  var C := A[0];
  for var i := 0 to N - 2 do
    A[i] := A[i + 1];
  
  A[N - 1] := C;
  
  Print('Измененный массив:');
end.

//Аналог через List<T>.
begin
  var L := ReadArrInteger(4).Println().ToList();
  L.Add(L[0]); L.RemoveAt(0);
  L.Println();
end.

Массив с максимумом максимумов

[править]

Вывести массив с максимумом максимумов двух массивов. 

begin
  var A := Arr(Arr(1, 2, 10), Arr(4, 5, 6)).MaxBy(x -> x.Max());
  Writeln(A);
  WritelnFormat('Индекс максимального элемента {0} равен {1}.', A.Max(), A.IndexMax(0));
end.

Смотрите также: реализация на Python.

Слияние отсортированных массивов

[править]
var
  C: array of integer;
  i, j, k: integer;

begin
  var A := Arr(1, 6, 7, 45, 100, 210);
  var B := Arr(2, 8);
  
  SetLength(C, A.Length + B.Length);
  while (i < A.Length) or (j < B.Length) do
  begin
    if (j >= B.Length) or (i < A.Length) and (j < B.Length) and (A[i] < B[j]) then
    begin
      C[k] := A[i];
      Inc(i);
    end
    else if (i >= A.Length) or (i < A.Length) and (j < B.Length) and (A[i] >= B[j]) then
    begin
      C[k] := B[j];
      Inc(j);
    end;
    Inc(k);
  end;
  
  C.Println();
end.

Разделение отрицательных и положительных чисел с сохранением порядка

[править]

Переместить все отрицательные числа в левую половину массива, остальные - в правую. Порядок следования отрицательных и неотрицательных чисел должен быть сохранен. 

const
  N = 10;
  D = 10;

var
  A: array [0..N - 1] of integer;

procedure Print();
begin
  for var i := 0 to N - 1 do
    Write(A[i]:4);
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
    A[i] := -D + Random(2 * D + 1);
  
  Print();
  
  for var i := 0 to N - 1 do
    for var j := N - 2 downto i + 1 do
      if (A[j] > 0) and (A[j + 1] < 0) then
        Swap(A[j], A[j + 1]);
  
  Print();
end.

Обработка матриц без условных операторов

[править]

Замена отрицательных элементов на неотрицательные

[править]
const
  N = 5;
  M = 5;

var
  A: array [0..N - 1, 0..M - 1] of integer;

procedure Print(d: integer);
begin
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:d);
    Writeln();
  end;
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := -10 + Random(20);
  
  Print(4);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := (1 - 2 * Ord(A[i, j] < 0)) * A[i, j];
  
  Print(4);
end.

Удвоить положительные элементы

[править]
const
  N = 5;
  M = 5;

var
  A: array [0..N - 1, 0..M - 1] of integer;

procedure Print(d: integer);
begin
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:d);
    Writeln();
  end;
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := -10 + Random(20);
  
  Print(4);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := (1 + Ord(A[i, j] > 0)) * A[i, j];
  
  Print(4);
end.

Исключение нечетных элементов

[править]
const
  N = 5;
  M = 5;

var
  A: array [0..N - 1, 0..M - 1] of integer;

procedure Print(d: integer);
begin
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:d);
    Writeln();
  end;
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := -10 + Random(20);
  
  Print(4);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Ord(Abs(A[i, j]) mod 2 = 0) * A[i, j];
  
  Print(4);
end.

Обнуление отрицательных чисел и удвоение положительных

[править]
const
  N = 5;

var
  A: array [0..N - 1] of integer;

procedure Print();
begin
  for var i := 0 to N - 1 do
    Write(A[i]:4);
  Writeln();
end;

begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  Print();
  
  for var i := 0 to N - 1 do
    A[i] := Ord(A[i] > 0) * 2 * A[i];
  Print();
end.

Задачи К. Полякова

[править]

Обработка массивов

[править]

Удаление лишних пробелов в строках массива

[править]
begin
  ReadArrString(3).Select(x -> x.ToWords().JoinIntoString(' ')).Println();
end.

Использование x.ToWords() не эквивалентно x.Split().

Смотрите также: реализация на Python.

Локальные минимумы

[править]

Дан массив, содержащий 2014 положительных целых чисел. Напишите на одном из языков программирования программу, которая находит в этом массиве количество локальных минимумов. Локальным минимумом называется элемент массива, который меньше всех своих соседей. Например, в массиве из 6 элементов, содержащем числа 4, 6, 12, 7, 3, 8, есть два локальных минимума: это элементы, равные 4 и 3. Программа должна вывести общее количество подходящих элементов, значения элементов выводить не нужно. Исходные данные объявлены так, как показано ниже. Запрещается использовать переменные, не описанные ниже, но разрешается не использовать часть из описанных. 

const
  N = 2014;

var
  A: array [0..N - 1] of integer;
  K: integer;

begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  if A[0] < A[1] then Inc(K);
  if A[N - 2] > A[N - 1] then Inc(K);
  
  for var i := 1 to N - 2 do
    if (A[i - 1] > A[i]) and (A[i] < A[i + 1]) then Inc(K);
  
  Writeln(K);
end.

Смотрите также: реализация на Python.

Минимальный чётный и нечётный элементы

[править]

Дан массив, содержащий неотрицательные целые числа, не превышающие 10 000. Необходимо вывести:

  1. минимальный чётный элемент, если количество чётных элементов не больше, чем нечётных;
  2. минимальный нечётный элемент, если количество нечётных элементов меньше, чем чётных.

Например, для массива из шести элементов, равных соответственно 4, 6, 12, 17, 9, 8, ответом будет 9 – наименьшее нечётное число, поскольку нечётных чисел в этом массиве меньше. 

const
  N = 20;

var
  A: array [0..N - 1] of integer;
  C1, C2, Min1, Min2: integer;

begin
  Min1 := integer.MaxValue;
  Min2 := integer.MaxValue;
  
  for var i := 0 to N - 1 do
  begin
    Readln(A[i]);
    if A[i] mod 2 = 0 then
    begin
      Inc(C1);
      if A[i] < Min1 then Min1 := A[i];
    end
    else
    begin
      Inc(C2);
      if A[i] < Min2 then Min2 := A[i];
    end;
  end;
  
  if C1 <= C2 then Writeln(Min1) else Writeln(Min2);
end.

//Аналог через готовые методы.
begin
  Writeln(ReadArrInteger(ReadlnInteger('N:')).GroupBy(x -> x mod 2 = 0).Last().Min()); 
end.

Смотрите также: реализация на Python.

Задача о сумме элементов

[править]

Дан целочисленный массив из 2000 элементов. Если сумма всех элементов массива чётная, нужно вывести количество нечётных (по значению) элементов массива, если нечётная – количество чётных. Например, для массива из 6 элементов, равных соответственно 2, 6, 12, 17, 3, 8, ответом будет 2 – количество нечётных элементов, так как общая сумма всех элементов чётна. 

const
  N = 2000;

var
  A: array [0..N - 1] of integer;
  S: integer;
  K1, K2: integer;

begin
  for var i := 0 to N - 1 do
  begin
    Readln(A[i]);
    Inc(S, A[i]);
    if A[i] mod 2 = 0 then Inc(K1) else Inc(K2);
  end;
  
  if S mod 2 = 0 then Write(K2) else Write(K1);
end.

//Аналог через готовые методы.
begin
  var A := ReadArrInteger(ReadlnInteger('N:'));
  Writeln(A.Count(x -> x mod 2 <> A.Sum() mod 2))
end.

Смотрите также: реализация на Python.

Пары с элементом кратным 3

[править]

Дан целочисленный массив из 20 элементов. Элементы массива могут принимать целые значения от –10 000 до 10 000 включительно. Опишите на естественном языке или на одном из языков программирования алгоритм, позволяющий найти и вывести количество пар элементов массива, в которых хотя бы одно число делится на 3. В данной задаче под парой подразумевается два подряд идущих элемента массива. 

const
  N = 20;

var
  A: array [0..N - 1] of integer;
  K: integer;

begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  for var i := 0 to N - 2 do
    if (A[i] mod 3 = 0) or (A[i + 1] mod 3 = 0) then Inc(K);
  
  Writeln(K);
end.

//Аналог через готовые методы.
begin
  Writeln(ReadArrInteger(ReadlnInteger('N:')).Pairwise((x, y) -> Ord((x mod 3) * (y mod 3) = 0)).Sum());
end.

Смотрите также: реализация на Python.

Числа, оканчивающиеся на 5

[править]

Дан целочисленный массив из 40 элементов. Элементы массива могут принимать целые значения от 0 до 10000 включительно. Опишите на естественном языке или на одном из языков программирования алгоритм, позволяющий найти и вывести количество пар элементов массива, в которых десятичная запись хотя бы одного числа оканчивается на 5. 

const
  N = 40;

var
  A: array [0..N - 1] of integer;
  K: integer;

begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  for var i := 0 to N - 1 do
    for var j := i + 1 to N - 1 do
      if (A[i] mod 10 = 5) or (A[j] mod 10 = 5) then Inc(K);
  
  Writeln(K);
end.

Смотрите также: реализация на Python.

Обработка строк

[править]

Удаление лишних пробелов

[править]
var
  S, S2: string;
  i: integer := 1;

begin
  Readln(S);
  while i <= Length(S) do
  begin
    if S.Chars[i] = ' ' then
    begin
      S2 += ' ';
      Inc(i);
    end;
    while (i <= Length(S)) and (S.Chars[i] = ' ') do Inc(i);
    while (i <= Length(S)) and (S.Chars[i] <> ' ') do
    begin
      S2 += S.Chars[i];
      Inc(i);
    end;
  end;
  S := S2;
  Writeln(S);
end.

Задача о школах

[править]

На вход программе подаются сведения о номерах школ учащихся, участвовавших в олимпиаде. В первой строке сообщается количество учащихся N, каждая из следующих N строк имеет формат: 

<Фамилия> <Инициалы> <номер школы>

где <Фамилия> – строка, состоящая не более чем из 20 символов, <Инициалы> – строка, состоящая из 4-х символов (буква, точка, буква, точка), <номер школы> – не более чем двузначный номер. <Фамилия> и <Инициалы>, а также <Инициалы> и <номер школы> разделены одним пробелом. Пример входной строки: 

Иванов П.С. 57

Требуется написать как можно более эффективную программу (укажите используемую версию языка программирования, например, Borland Pascal 7.0), которая будет выводить на экран информацию, из какой школы было меньше всего участников (таких школ может быть несколько). При этом необходимо вывести информацию только по школам, пославшим хотя бы одного участника. Следует учитывать, что N >= 1000. 

const
  N = 4;
  M = 99;
  
var
  Schools: array [1..M] of integer;
  Data: string;
  Max, MaxI: integer;

begin
  for var i := 0 to N - 1 do
  begin
    Readln(Data);
    Inc(Schools[StrToInt(Data.ToWords()[2])]);
  end;
  
  Max := integer.MinValue;
  for var i := 1 to M do
    if Schools[i] > Max then
    begin
      Max := Schools[i];
      MaxI := i;
    end;
  
  WritelnFormat('В школу с номером {0} пришло наибольшее количество учеников ({1}).', MaxI, Max);
end.

Худшие ученики

[править]

Вариант задачи 1

[править]

На вход программе подаются сведения о сдаче экзаменов учениками 9-х классов некоторой средней школы. В первой строке сообщается количество учеников N, которое не меньше 10, но не превосходит 100, каждая из следующих N строк имеет следующий формат: 

<Фамилия> <Имя> <оценки>

, где <Фамилия> – строка, состоящая не более чем из 20 символов, <Имя> – строка, состоящая не более чем из 15 символов, <оценки> – через пробел три целых числа, соответствующие оценкам по пятибалльной системе. <Фамилия> и <Имя>, а также <Имя> и <оценки> разделены одним пробелом. Пример входной строки: 

Иванов Петр 4 5 3

Требуется написать как можно более эффективную программу (укажите используемую версию языка программирования, например, Borland Pascal 7.0), которая будет выводить на экран фамилии и имена трех худших по среднему баллу учеников. Если среди остальных есть ученики, набравшие тот же средний балл, что и один из трех худших, то следует вывести и их фамилии и имена. 

const
  N = 6;
  M = 3;

type
  TStudent = class
  public 
    Name, Surname: string;
    Assessments: array [0..2] of integer;
    
    constructor(n, sn: string; r1, r2, r3: integer);
    begin
      Name := n;
      Surname := sn;
      Assessments[0] := r1;Assessments[1] := r2;Assessments[2] := r3;
    end;
    
    function Sum()  := Assessments[0] + Assessments[1] + Assessments[2];
  end;

var
  Students: array of TStudent;
  Data: string;
  j: integer;

begin
  SetLength(Students, N);
  for var i := 0 to N - 1 do
  begin
    Readln(Data);
    var a := Data.ToWords();
    Students[i] := new TStudent(a[0], a[1], StrToInt(a[2]), StrToInt(a[3]), StrToInt(a[4]));
  end;
  
  Students := Students.OrderBy(v -> v.Assessments.Sum()).ToArray();
  
  var i := 0;
  var Sum := Students[0].Sum();
  while i < N do
  begin
    while (i < N) and (Students[i].Sum() = Sum) do
    begin
      WritelnFormat('Ученик {0} {1} {2}-ый по счету имеет баллы {3}.', Students[i].Name, Students[i].Surname, j + 1, Students[i].Sum());
      Inc(i);
    end;
    
    if i < N then
    begin
      Inc(j);
      Sum := Students[i].Sum();
    end;
    
    if j >= M then break;
  end;
end.

Вариант задачи 2

[править]

Вывести имена трех худших учеников и среднее арифметическое их баллов. 

begin
  ReadArrString(20).Select(x -> x.ToWords()).OrderBy(x -> x.Skip(2).Sum(v -> StrToInt(v))).
  Select(x -> Format('{0} {1} {2}', x[0], x[1], x.Skip(2).Average(v -> StrToFloat(v)))).Take(3).Println();
end.

Абитуриенты, не допущенные к сдаче экзаменов

[править]

В некотором вузе абитуриенты проходят предварительное тестирование, по результатам которого могут быть допущены к сдаче вступительных экзаменов в первом потоке. Тестирование проводится по двум предметам, по каждому предмету абитуриент может набрать от 0 до 100 баллов. При этом к сдаче экзаменов в первом потоке допускаются абитуриенты, набравшие по результатам тестирования не менее 30 баллов по каждому из двух предметов. На вход программы подаются сведения о результатах предварительного тестирования. Известно, что общее количество участников тестирования не превосходит 500. В первой строке вводится количество абитуриентов, принимавших участие в тестировании, N. Далее следуют N строк, имеющих следующий формат: 

<Фамилия> <Имя> <Баллы>

Здесь <Фамилия> – строка, состоящая не более чем из 20 символов; <Имя> – строка, состоящая не более чем из 15 символов; <Баллы> – строка, содержащая два целых числа, разделенных пробелом, соответствующих баллам, полученным на тестировании по каждому из двух предметов. При этом <Фамилия> и <Имя>, <Имя> и <Баллы> разделены одним пробелом. Примеры входных строк: 

Ветров Роман 68 59
Анисимова Екатерина 64 88

Напишите программу, которая будет выводить на экран фамилии и имена абитуриентов, потерпевших неудачу, то есть не допущенных к сдаче экзаменов в первом потоке. При этом фамилии должны выводиться в алфавитном порядке. 

const
  N = 3;

type
  TPerson = auto class
    Surname, Name: string;
    Assessments: array of integer;
  end;

var
  A: array of TPerson;

begin
  SetLength(A, N);
  for var i := 0 to N - 1 do
  begin
    var p := ReadlnString().ToWords();
    A[i] := new TPerson(p[0], p[1], p.Skip(2).Select(x -> StrToInt(x)).ToArray());
  end;
  
  Writeln('Не прошли экзамен:');
  A.Where(x -> x.Assessments.Any(y -> y < 30)).OrderBy(x -> x.Name).
  Select(x -> Format('{0} {1} {2}', x.Surname, x.Name, x.Assessments.JoinIntoString()) + NewLine).Println('');
end.

const
  N = 3;

type
  TPerson = record
    Surname, Name: string;
    Assessments: array of integer;
  end;

var
  A: array of TPerson;

begin
  SetLength(A, N);
  for var i := 0 to N - 1 do
  begin
    var p := ReadlnString().ToWords();
    A[i].Surname := p[0];
    A[i].Name := p[1];
    A[i].Assessments := p.Skip(2).Select(x -> StrToInt(x)).ToArray();
  end;
  
  Writeln('Не прошли экзамен:');
  A.Where(x -> x.Assessments.Any(y -> y < 30)).OrderBy(x -> x.Name).
  Select(x -> Format('{0} {1} {2}', x.Surname, x.Name, x.Assessments.JoinIntoString()) + NewLine).Println('');
end.

Задача о сотрудниках

[править]

На вход программе подаются сведения о телефонах всех сотрудников некоторого учреждения. В первой строке сообщается количество сотрудников N, каждая из следующих N строк имеет следующий формат: 

<Фамилия> <Инициалы> <телефон>

где <Фамилия> – строка, состоящая не более чем из 20 символов, <Инициалы> - строка, состоящая не более чем из 4-х символов (буква, точка, буква, точка), <телефон> – семизначный номер, 3-я и 4, я, а также 5-я и 6-я цифры которого разделены символом «–». <Фамилия> и <Инициалы>, а также <Инициалы> и <телефон> разделены одним пробелом. Пример входной строки: 

Иванов П.С. 555-66-77

Сотрудники одного подразделения имеют один и тот же номер телефона. Номера телефонов в учреждении отличаются только двумя последними цифрами. Требуется написать как можно более эффективную программу, которая будет выводить на экран информацию, сколько в среднем сотрудников работает в одном подразделении данного учреждения. 

const
  N = 3;

var
  A: array of string;

begin
  SetLength(A, N);
  for var i := 0 to N - 1 do
    A[i] := ReadlnString().ToWords()[2];
  
  Writeln(A.GroupBy(s -> s.ToWords()[2]).Println(NewLine).Average(g -> g.Count));
end.

Задача о сметанах

[править]

В молочных магазинах города Х продается сметана с жирностью 15, 20 и 25 процентов. В городе X был проведен мониторинг цен на сметану. Напишите эффективную по времени работы и по используемой памяти программу, которая будет определять для каждого вида сметаны, сколько магазинов продают ее дешевле всего. На вход программе сначала подается число магазинов N. В каждой из следующих N строк находится информация в следующем формате: 

<Фирма> <Улица> <Жирность> <Цена>

где <Фирма> – строка, состоящая не более, чем из 20 символов без пробелов, <Улица> – строка, состоящая не более, чем из 20 символов без пробелов, <Жирность> – одно из чисел – 15, 20 или 25, <Цена> – целое число в диапазоне от 2000 до 5000, обозначающее стоимость одного литра сметаны в копейках. <Фирма> и <Улица>, <Улица> и <Жирность>, а также <Жирность> и <Цена> разделены ровно одним пробелом. Пример входной строки: 

Перекресток Короленко 25 3200

Программа должна выводить через пробел 3 числа – количество магазинов, продающих дешевле всего сметану с жирностью 15, 20 и 25 процентов. Если какой-то вид сметаны нигде не продавался, то следует вывести 0. Пример выходных данных: 

12 10 0

const
  N = 5;

type
  TData = auto class
    MinPrice, Count: integer;
  end;

var
  FatContent: array [0..2] of TData;

begin
  for var i := 0 to 2 do
    FatContent[i] := new TData(integer.MaxValue, 0);
  
  for var i := 0 to N - 1 do
  begin
    var p := ReadlnString().ToWords();
    var j := (StrToInt(p[2]) - 15) div 5;
    var price := StrToInt(p[3]);
    if price < FatContent[j].MinPrice then
    begin
      FatContent[j].MinPrice := price;
      FatContent[j].Count := 1;
    end
    else if price = FatContent[j].MinPrice then Inc(FatContent[j].Count);
  end;
  
  WritelnFormat('{0} {1} {2}', FatContent[0].Count, FatContent[1].Count, FatContent[2].Count);
end.

const
  N = 5;

type
  TData = record
    MinPrice, Count: integer;
  end;

var
  FatContent: array [0..2] of TData;

begin  
  for var i := 0 to N - 1 do
  begin
    var p := ReadlnString().ToWords();
    var j := (StrToInt(p[2]) - 15) div 5;
    var price := StrToInt(p[3]);
    if price < FatContent[j].MinPrice then
    begin
      FatContent[j].MinPrice := price;
      FatContent[j].Count := 1;
    end
    else if price = FatContent[j].MinPrice then Inc(FatContent[j].Count);
  end;
  
  WritelnFormat('{0} {1} {2}', FatContent[0].Count, FatContent[1].Count, FatContent[2].Count);
end.

Задача о партиях

[править]

Имеется список результатов голосования избирателей за несколько партий, в виде списка названий данных партий. На вход программе в первой строке подается количество избирателей в списке N. В каждой из последующих N строк записано название партии, за которую проголосовал данный избиратель, в виде текстовой строки. Длина строки не превосходит 50 символов, название может содержать буквы, цифры, пробелы и прочие символы. Пример входных данных: 

6
Party one
Party two
Party three
Party three
Party two
Party three

Программа должна вывести список всех партий, встречающихся в исходном списке, в порядке убывания количества голосов, отданных за эту партию. При этом название каждой партии должно быть выведено ровно один раз, вне зависимости от того, сколько голосов было отдано за данную партию. Пример выходных данных для приведенного выше примера входных данных: 

Party three
Party two
Party one

var
  D: Dictionary<string, integer>;

begin
  D := new Dictionary<string, integer>();
  
  for var i := 0 to ReadlnInteger('Количество избирателей:') - 1 do
  begin
    var p := ReadlnString();
    if not D.ContainsKey(p) then D.Add(p, 1) else D[p] += 1;
  end;
  
  Writeln();
  D.OrderByDescending(x -> x.Value).Select(x -> x.Key).JoinIntoString(NewLine).Println();
end.

//Аналог через готовые методы.
begin
  ReadArrString(ReadlnInteger()).GroupBy(x -> x).OrderByDescending(x -> x.Count()).Select(x -> x.First()).JoinIntoString(NewLine).Println();
end.

Задача о цифрах

[править]

На вход программе подается последовательность символов, заканчивающаяся точкой. Требуется написать программу, которая определяет, есть ли в этой последовательности десятичные цифры, и выводит наибольшее число, которое можно составить из этих цифр. Ведущих нулей в числе быть не должно (за исключением числа 0, запись которого содержит ровно одну цифру). Если цифр нет, программа должна вывести на экран слово «Нет», а если есть – слово «Да» и в следующей строчке искомое число. Например, если исходная последовательность была такая: 

Day 10, mice 8: "Year" 7 is a mistake 91.

то результат должен быть следующий: 

Да
987110

begin
  var A := ReadlnString().Where(x -> char.IsDigit(x));
  Writeln(A.Count > 0 ? Format('{0}{1}{2}', 'Да', NewLine, A.OrderByDescending(x -> x).JoinIntoString('')) : 'Нет');
end.

Математические задачи

[править]

Задача о принадлежности точки кольцу

[править]
var
  R1, R2, X, Y: real;

begin
  Readln(R1, R2, X, Y);
  if R1 > R2 then Swap(R1, R2);
  var D := Sqrt(Sqr(X) + Sqr(Y));
  if (D > R1) and (D < R2) then Writeln('Точка внутри кольца.') else Writeln('Точка вне кольца.');
end.

Смотрите также: реализация на Python.

Задача о решении уравнений

[править]
var
  A, B, C, D, X1, X2: real;

begin
  Readln(A, B, C);
  D := Sqr(B) - 4 * A * C;
  if D >= 0 then
  begin
    var d2 := Sqrt(D);
    var a2 := 2 * A;
    X1 := (-B + d2) / a2;
    X2 := (-B - d2) / a2;
    if X1 = X2 then
      WritelnFormat('Найден один корень, равный {0}', X1)
    else
      WritelnFormat('Найдены два корня, равные {0} и {1}', X1, X2);
  end
  else
    WritelnFormat('Ошибка нахождения корней: недопустимое значение {0} для D (< 0).', D);
end.

Смотрите также: реализация на Python.

Простое число с максимальным количеством единиц в двоичном представлении

[править]
function F(a: integer): integer;
begin
  while a <> 0 do
  begin
    if a mod 2 = 1 then Inc(Result);
    a := a div 2;
  end;
end;

begin
  Writeln(ReadArrInteger(10).Where(x -> (x = 1) or (Range(2, Trunc(Sqrt(x))).All(y -> x mod y <> 0))).MaxBy(x -> F(x)));
end.

//Аналог через готовые методы.
begin
  Writeln(ReadArrInteger(10).Where(x -> (x = 1) or (Range(2, Trunc(Sqrt(x))).All(y -> x mod y <> 0))).
    MaxBy(x -> System.Convert.ToString(x, 2).Count(ch -> ch = '1')));
end.

Простое число

[править]
function IsPrime(a: integer): boolean;
begin
  Result := false;
  if (a mod 2 = 0) and (a <> 2) then exit;
  
  var i := 3;
  while i <= Round(Sqrt(a)) do
    if a mod i = 0 then
      exit
    else
      Inc(i, 2);
  Result := true;
end;

begin
  var X := ReadlnInteger();
  WritelnFormat('Число {0} {1}простое.', X, IsPrime(X) ? '' : 'не');
end.

Подсчёт числа инверсий

[править]
begin
  var A := ArrRandom(10, 0, 10);
  Writeln(A);
  
  var Count := 0;
  for var i := 0 to A.Length - 1 do
    for var j := i + 1 to A.Length - 1 do
      if A[j] > A[i] then
        Inc(Count);
  
  WritelnFormat('Количество инверсий равно {0}.', Count);
end.

Интегрирование

[править]
type
  TFunction = function(x: real): real;

function Integrate(a, b: real; c: integer; func: TFunction): real;
begin
  var s := (b - a) / c;
  for var i := 0 to c - 1 do
    Result += Abs(func(a + i * s));
  Result *= s;
end;

begin
  Writeln(Integrate(-1, 1, 100, Sin));
end.

Ханойские башни

[править]
var
  N: integer;

procedure F(d, l1, l2: integer);
var
  delta, dm: integer;

begin
  delta := 6 - l1 - l2;
  dm := d - 1;
  if d <> 1 then F(dm, l1, delta);
  WritelnFormat('Диск {0} переставлен на {1} на {2}.', d, l1, l2);
  if d <> 1 then F(dm, delta, l2);
end;

begin
  Readln(N);
  F(N, 1, 3);
end.

Повышенная сложность

[править]

Задачи на алгоритмы

[править]

Задачи на обработку последовательностей

[править]

Числа, удовлетворяющие условию

[править]

Подсчитать количество чисел, принадлежащих промежутку [A, B] и сумму чисел, стоящих на местах, кратных 3. 

begin
  var A := ReadlnInteger('A:');
  var B := ReadlnInteger('B:');
  
  var i := 0;
  var Sum := 0;
  var Count := 0;
  
  var N := 0;
  
  while i < B - A + 1 do
  begin
    Readln(N);
    if (N >= A) and (N <= B) then Inc(Count);
    if i mod 3 = 0 then Inc(Sum, N);
    Inc(i);
  end;
  
  WritelnFormat('Количество чисел в [A, B] равно {0}. Сумма чисел равна {1}.', Count, Sum);
end.

begin
  var A := ReadArrInteger(ReadlnInteger('N:'));
  var R := Range(ReadlnInteger('A:'), ReadlnInteger('B:'));
  
  WritelnFormat('Количество чисел, принадлежащих промежутку [{0}, {1}] равно {2}. ' + NewLine 
                + 'Сумма чисел, стоящих на местах, кратных 3, равна {3}.',
                R.First(), R.Last(), A.Count(x -> x in R), A.Where((x, i)-> i mod 2 = 0).Sum());
end.

Последовательность максимальной длины

[править]
Вариант с файлом
[править]
const
  Path1 = 'C:\Ilya\AlgoРитмы\Файл1.txt';
  Path2 = 'C:\Ilya\AlgoРитмы\Файл2.txt';

var
  F1, F2: Text;
  L: List<integer>;
  N: integer;
  MaxL: integer;

begin
  Assign(F1, Path1);
  Assign(F2, Path2);
  Reset(F1);
  Rewrite(F2);
  
  L := new List<integer>();
  
  while not Eof(F1) do
  begin
    Readln(F1, N);
    L.Add(N);
  end;
  
  var i := 0;
  N := L[0];
  while i < L.Count do
  begin
    var len := 1;
    while (i < L.Count) and (L[i] = N) do
    begin
      Inc(len);
      Inc(i);
    end;
    if len > MaxL then
      MaxL := len;
    if i < L.Count then
      N := L[i];
  end;
  
  Write(F2, MaxL);
  Close(F1);
  Close(F2);
end.
Вариант без файла
[править]
begin
  Writeln(ReadlnString().AdjacentGroup().MaxBy(x -> x.Count()).First());
end.

Задача с CyberForum

[править]
  1. Заполнить массив по формуле: 5.5 * Sin(index * H) + Cos(A * X + index * H), где H, A и X - числа, которые ввел пользователь.
  2. Удалить из массива все положительные элементы, которые удовлетворяют условию: A[index] < index / 3.
  3. Найти среднее арифметическое элементов, стоящих между первым минимальным по модулю и последним отрицательным элементами.
const
  N = 10;
 
var
  A: array [1..N] of real;
  Exists: array [1..N] of boolean;
  NegativeI: integer;
 
begin
  var H := ReadlnInteger();
  var X := ReadlnInteger();
  var A := ReadlnInteger();
  
  for var i := 1 to N do
  begin
    var c := i * H;
    A[i] := 5.5 * Sin(c) + Cos(A * X + c);
    Exists[i] := true;
  end;
  
  for var i := 1 to N do
    if (A[i] > 0) and (A[i] < i / 3) then
      Exists[i] := false;
  
  var Min := real.MaxValue;
  var MinI := 0;
  for var i := 1 to N do
    if Exists[i] and (Abs(A[i]) < Min) then
    begin
      Min := Abs(A[i]);
      MinI := i;
    end;
  
  for NegativeI := N downto 1 do
    if Exists[NegativeI] and (A[NegativeI] < 0) then
      break;
  
  var Sum := 0.0;
  var Count := 0;
  for var i := MinI to NegativeI do
    if Exists[i] then
    begin
      Sum += A[i];
      Inc(Count);
    end;
  
  WritelnFormat('Среднее арифметическое равно {0}.', Sum / Count);
end.

Определить является ли данная последовательность арифметической прогрессией

[править]
begin
  var A := ReadlnInteger();
  var B := ReadlnInteger();
  var D := B - A;
  var Yes := true;
  
  while Yes and (B <> 0) do
  begin
    Swap(A, B);
    B := ReadlnInteger();
    if (B <> 0) and (B - A <> D) then
      Yes := false;
  end;
  
  if Yes then Writeln('Yes') else Writeln('No');
end.

//Аналог через готовые методы.
const
  Eps = 1E-5;

begin
  var A := ReadlnString().ToReals().Incremental((x, y) -> y - x);
  WritelnFormat('Последовательность - {0}арифметическая прогрессия.', A.All(x -> Abs(x - A.First()) < Eps) ? '' : 'не ');
end.

Сжатие последовательности

[править]
Вариант первый
[править]

Из последовательности 1, 1, 3, 3, 5, 1 получить: 

1:2
3:2
5:1
1:1

const
  N = 6;
 
var
  A: array [0..N - 1] of integer;
 
begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  var K := A[0];
  var Count := 0;
  
  var i := 0;
  while i < N do
  begin
    while (i < N) and (A[i] = K) do
    begin
      Inc(i);
      Inc(Count);
    end;
    WritelnFormat('{0}:{1}', K, Count);
    if i < N then
    begin
      K := A[i];
      Count := 0;
    end;
  end;
end.
Вариант второй
[править]
//Аналог через готовые методы.
begin
  ReadlnString().AdjacentGroup().Select(x -> Format('{0}({1})', x.First, x.Count)).JoinIntoString('').Println();
end.

Удаление двух максимумов и двух минимумов

[править]
begin
  var A := Arr(1, 2, 34, 4, 15, 6, 71, 8, 9);
  A := A.Numerate().Println().OrderBy(x -> x[1]).Skip(2).SkipLast(2).OrderBy(x -> x[0]).Select(x -> x[1]).ToArray();
  Writeln(A);
end.

Случайные последовательности

[править]
Последовательность без повторений
[править]
const
  D = 5;

begin
  for var i := 1 to 10 do
  begin
    var m := i * D;
    Writeln(Random(m, m + D - 1));
  end;
end.

Обработка чисел

[править]

Перевод секунд в часы, минуты и секунды

[править]
begin
  var Seconds := ReadlnInteger();
  var H := Seconds div 3600 mod 24;
  var M := Seconds mod 3600 div 60;
  var S := Seconds mod 60; 
  WritelnFormat('{0}:{1}:{2}', H, M, S);
end.

Вывод делителей числа

[править]
begin
  var X := ReadInteger('Введите целое число x (x > 1): ');
  Assert(X > 1);
  
  var I := 2;
  WriteFormat('{0} = 1', X);
  
  repeat
    if X mod I = 0 then
    begin
      WriteFormat(' * {0}', I);
      X := X div I;
    end
    else
      I += 1;
  until X = 1;
  
  Writeln();
end.

Вывод цифр числа в правильном порядке

[править]
var
  N: integer;
  C: integer;

begin
  Readln(N);
  
  var N2 := N;
  while N2 <> 0 do
  begin
    Inc(C);
    N2 := N2 div 10;
  end;
  Dec(C);
  C := Round(Power(10, C));
  
  while C > 0 do
  begin
    Writeln(N div C);
    N := N mod C;
    C := C div 10;
  end;
end.

Переворот числа

[править]
var
  N: integer;
  C: integer;

begin
  Readln(N);
  
  var N2 := N;
  while N2 <> 0 do
  begin
    Inc(C);
    N2 := N2 div 10;
  end;
  Dec(C);
  C := Round(Power(10, C));
  
  N2 := 0;
  while N > 0 do
  begin
    N2 += N mod 10 * C;
    N := N div 10;
    C := C div 10;
  end;
  Writeln(N2);
end.

Квадраты чисел

[править]

Найти все такие числа, запись которых совпадает с последними цифрами их квадрата. 

function IsSuitable(a: integer): boolean;
begin
  var b := Sqr(a);
  
  Result := true;
  while Result and (a <> 0) do
  begin
    if a mod 10 <> b mod 10 then Result := false;
    a := a div 10;
    b := b div 10;
  end;
end;

begin
  var N:=ReadlnInteger();
  
  for var i := 1 to N do
    if IsSuitable(i) then Writeln(i);
end.

Поиск натурального N

[править]

Вычислить такое N, при котором последовательность вида Sqrt(6 + Sqrt(6 + Sqrt(6 + ... Sqrt(6)))) / N приближается к 3 с погрешностью 10^(-4). 

const
  Infelicity = 1E-4;

begin
  var F := Sqrt(6.0);
  var N := 1;
  
  while Abs(F - 3) > Infelicity do
  begin
    F := Sqrt(6 + F);
    Inc(N);
  end;
  
  WritelnFormat('N = {0}.', N);
end.

Поиск наибольшего общего делителя

[править]
Для пары чисел
[править]
begin
  var A := ReadlnInteger('A:');
  var B := ReadlnInteger('B:');
  
  while (A <> 0) and (B <> 0) do
    if A > B then A := A mod B else B := B mod A;
  
  Writeln(A + B);
end.
Для N чисел
[править]
const
  N = 4;

var
  A: array[0..N - 1] of integer;
  Outcome: integer;

function F(a, b: integer): integer;
begin
  while (a <> 0) and (b <> 0) do
    if a > b then a := a mod b else b := b mod a;
  Result := a + b;
end;


begin
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  Outcome := F(A[0], A[1]);
  for var i := 2 to N - 1 do
    Outcome := F(Outcome, A[i]);
  WritelnFormat('НОД = {0}.', Outcome);
end.

Таблица умножения в шестнадцатеричной системе счисления

[править]
const
  S = '0123456789ABCDEF';

function ToHex(x: integer): string;
begin
  while x <> 0 do
  begin
    Result := S.Chars[x mod 16 + 1] + Result;
    x := x div 16;
  end;
end;

begin
  for var i := 1 to 9 do
  begin
    for var j := 1 to 9 do
      Write(ToHex(i * j):5);
    Writeln();
  end;
end.

Поразрядное сравнение чисел

[править]
begin
  var A := ReadlnInteger('A:');
  var B := ReadlnInteger('B:');
  var C := 0;
  
  while (A <> 0) and (B <> 0) do
  begin
    if A mod 10 = B mod 10 then Inc(C);
    A := A div 10;
    B := B div 10;
  end;
  WritelnFormat('Количество совпадений в равносильных разрядах чисел равно {0}.', C);
end.

Задачи на матрицы

[править]

Обнуление элементов, стоящих выше главной диагонали и ниже побочной

[править]
begin
  var N := ReadlnInteger();
  var A := MatrRandom(N, N, 1, 10);
  A.Println();
  
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i < j) and (N - i - 1 < j) then
        A[i, j] := 0;
  
  Writeln();
  A.Println();
end.

Треугольник Паскаля

[править]
const
  M = 15;

var
  A: array[1..M, 1..M] of integer;
  N: integer;

begin
  Write('Количество итераций: ');
  Readln(N);
  
  A[1, 1] := 1;
  
  for var i := 2 to N + 1 do
    for var j := 1 to N + 1 do
      if (j = 1) or (j = i) then
        A[i, j] := 1
      else
        A[i, j] := A[i - 1, j - 1] + A[i - 1, j];
  
  for var i := 1 to N do 
  begin
    for var j := 1 to N do
      if A[i, j] <> 0 then write(A[i, j]:5);
    Writeln();
  end;
end.

Перемножение матриц

[править]
var
  MatrixA, MatrixB: array [,] of integer;
 
procedure PrintMatrix(matrix: array [,] of integer);
begin
  for var i := 0 to Length(matrix, 0) - 1 do
  begin
    for var j := 0 to Length(matrix, 1) - 1 do
      Write(matrix[i, j]:4);
    Writeln();
  end;
end;
 
function MultMatrixes(matrixA, matrixB: array [,] of integer): array [,] of integer;
begin
  if Length(matrixA, 1) = Length(matrixB, 0) then
  begin
    SetLength(Result, Length(matrixA, 0), Length(matrixB, 1));
    for var i := 0 to Length(Result, 0) - 1 do
      for var j := 0 to Length(Result, 1) - 1 do
        for var AjBi := 0 to Length(matrixA, 1) - 1 do
            Result[i, j] += matrixA[i, AjBi] * matrixB[AjBi, j];
  end
  else
    raise new Exception('Количество столбцов первой матрицы не равно количеству строк второй.');
end;

begin
  SetLength(MatrixA, 3, 2);
  SetLength(MatrixB, 2, 2);
  
  for var i := 0 to Length(MatrixA, 0) - 1 do
    for var j := 0 to Length(MatrixA, 1) - 1 do
      MatrixA[i, j] := Random(6);
  
  for var i := 0 to Length(MatrixB, 0) - 1 do
    for var j := 0 to Length(MatrixB, 1) - 1 do
      MatrixB[i, j] := Random(6);
  
  Writeln('MatrixA:');
  PrintMatrix(MatrixA);
  Writeln();
  
  Writeln('MatrixB:');
  PrintMatrix(MatrixB);
  Writeln();
  
  Writeln('MatrixC:');
  PrintMatrix(MultMatrixes(MatrixA, MatrixB));
end.

Сортировки

[править]

Быстрая сортировка

[править]
Описание алгоритма
  1. Найти средний элемент.
  2. Выполнять цикл до тех пор пока элементы x[i] и x[j] находятся на правильных местах (x[i]-ый левее или на той же позиции, что и x[j]).
  3. Найти такой i-ый элемент, что он будет больше или равен m.
  4. Найти такой j-ый элемент, что он будет меньше или равен m.
  5. Если элементы i-ый и j-ый нашлись, то если они находятся в правильном порядке, поменять их местами и сдвинуть i на 1 вправо, а j - на 1 влево.
  6. Если длина подмассива от l до j превышает или равна 1, то вызвать рекурсивно для нее процедуру.
  7. Если длина подмассива от i до r превышает или равна 1, то вызвать рекурсивно для нее процедуру.
const
  N = 10;

var
  A: array of integer;

procedure Sort(var x: array of integer; l, r: integer);
var
  i, j, m: integer;
begin
  i := l; 
  j := r; 
  m := x[(l + r) div 2];
  
  while i <= j do
  begin
    while x[i] < m do Inc(i); 
    while x[j] > m do Dec(j); 
    if i <= j then 
    begin
      Swap(x[i], x[j]); 
      Inc(i); 
      Dec(j);
    end;
  end;
  
  if l < j then Sort(x, l, j); 
  if i < r then Sort(x, i, r); 
end;

begin
  SetLength(A, N);
  
  for var i := 0 to N - 1 do A[i] := Random(100);
  
  Writeln(A); 
  Sort(A, 0, N - 1); 
  Writeln(A); 
end.
  1. Элементы x[i], x[j] рано или поздно найдутся: поскольку даже если все элементы стоят на своих местах, то x[i] и x[j] будут равны m.
  2. Если i пробежал n элементов и указывает на n + 1, то все n элементов стоят на правильных местах. Аналогично и с j.

Бинарный поиск

[править]
const
  N = 10;

var
  A: array of integer;

procedure Sort(var x: array of integer; l, r: integer);
var
  i, j, m: integer;
begin
  i := l; 
  j := r; 
  m := x[round((l + r) / 2)];
  
  repeat
    while x[i] < m do Inc(i); 
    while x[j] > m do Dec(j); 
    if i <= j then 
    begin
      Swap(x[i], x[j]); 
      Inc(i); 
      Dec(j); 
    end; 
  until i > j;
  
  if l < j then Sort(x, l, j); 
  if i < r then Sort(x, i, r); 
end;

procedure BinarySeach(var a: array of integer; x, l, r: integer);
  function NewMiddle()  := round((l + r) / 2);

begin
  var m := NewMiddle();
  
  while l <= r do
  begin
    if a[m] = x then
    begin
      WritelnFormat('Элемент {0} был найден в позиции {1}.', x, m);
      exit;
    end
    else if x > a[m] then
    begin
      l := m + 1;
      m := NewMiddle();
    end
    else
    begin
      r := m - 1;
      m := NewMiddle();
    end
  end;
  WritelnFormat('Не обнаружено элемента со значением {0}.', x);
end;

begin
  SetLength(A, N);
  for var i := 0 to N - 1 do
    A[i] := Random(10);
  
  Sort(A, 0, N - 1);
  Writeln(A);
  BinarySeach(A, 4, 0, N - 1);
end.

Смотрите также: реализация на Python

Математические задачи

[править]

Задача про фундамент

[править]

Вычислить значения все N при изначальном F1, шаге H и последнем F2. Причем, применялись формулы: 

F = (N - RS) / (D - R), если F > 0.03S
F = (N - RS) / D, если F ≤ 0.03S

begin
  var F1 := ReadlnInteger('F1:');
  var F2 := ReadlnInteger('F2:');
  var H := ReadlnInteger('H:');
  
  var R := ReadlnInteger('R:');
  var S := ReadlnInteger('S:');
  var D := ReadlnInteger('D:');
  
  while F1 <= F2 do
  begin
    if F1 > 0.03 * S then
      Writeln(F1 * (D - R) + R * S)
    else
      Writeln(F1 * D + R * S);
    Inc(F1, H);
  end;
end.

Треугольник с максимальным периметром

[править]
const
  N = 6;

type
  TPoint = auto class
    X, Y: integer;
  end;
  
  TPointComparer = auto class(IEqualityComparer<TPoint>)
  public 
    function Equals(a, b: TPoint) := (a.X = b.X) and (a.Y = b.Y);
    
    function GetHashCode(a: TPoint) := 0;
  end;

function Distance(a, b: TPoint) := Sqrt(Sqr(b.X - a.X) + Sqr(b.Y - a.Y));

function IsTriangle(a, b, c: TPoint): boolean;
begin
  var d1 := Distance(a, b);
  var d2 := Distance(b, c);
  var d3 := Distance(c, a);
  Result := (d1 + d2 <> d3) and (d2 + d3 <> d1) and (d3 + d1 <> d2);
end;

function Perimeter(a, b, c: TPoint) := Distance(a, b) + Distance(b, c) + Distance(c, a);

begin
  var A := ReadArrInteger(N).Batch(2).Select(x -> new TPoint(x.First, x.Last)).Distinct(new TPointComparer()).ToArray();
  
  Writeln(A);
  
  var P := 0.0;
  for var i := 0 to Length(A) - 1 do
    for var j := i + 1 to Length(A) - 1 do
      for var k := j + 1 to Length(A) - 1 do
      begin
        var P2 := Perimeter(A[i], A[j], A[k]);
        if IsTriangle(A[i], A[j], A[k]) and (P2 > P) then
          P := P2;
      end;
  
  if P > 0.0 then
    WritelnFormat('Треугольник с максимальным P = {0} существует.', P)
  else
    Writeln('Треугольник с максимальным P не существует.');
end.
Разделы справки, которые могут помочь:
  1. Классы -> Автоклассы.
  2. Интерфейсы.

IEqualityComparer<T> - что такое?

Суммы цифр чисел файла

[править]
var
  N, S: integer;
  F: Text;

begin
  Assign(F, 'C:\Ilya\AlgoРитмы\Сохраненные задачи\Файлы\test.txt');
  Reset(F);
  while not Eof(F) do
  begin
    Read(F, N);
    while N <> 0 do
    begin
      S += N mod 10;
      N := N div 10;
    end;
    WriteFormat('{0} ', S);
    S := 0;
  end;
  
  Writeln();
  Close(F);
end.

Ближайшая и дальняя точки

[править]
const
  N = 4;

type
  TPoint = record
    X, Y: real;
    Dist: real;
  end;

var
  A: array [0..N] of TPoint;
  Found: boolean;

begin
  for var i := 0 to N - 1 do
  begin
    A[i].X := ReadlnReal('X:');
    A[i].Y := ReadlnReal('Y:');
    A[i].Dist := Sqrt(Sqr(A[i].X) + Sqr(A[i].Y));
  end;
  
  var Min := real.MaxValue;
  var MinI := 0;
  
  for var i := 0 to N - 1 do
  begin
    if A[i].Dist < Min then
    begin
      Min := A[i].Dist;
      MinI := i;
    end;
  end;
  
  WritelnFormat('Ближняя точка {0} имеет расстоянее до начала координат, равное {1}.', MinI, Min);
  
  Found := false;
  for var i := 0 to N - 1 do
    if (MinI <> i) and (Min = A[i].Dist) then
    begin
      WritelnFormat('Точка {0} также близка как ближайшая к началу координат.', i);
      Found := true;
    end;
  if not Found then Writeln('Более ближайших точек не обнаружено.');
  
  var Max := real.MinValue;
  var MaxI := 0;
  
  for var i := 0 to N - 1 do
  begin
    if A[i].Dist > Max then
    begin
      Max := A[i].Dist;
      MaxI := i;
    end;
  end;
  
  WritelnFormat('Дальняя точка {0} имеет расстоянее до начала координат, равное {1}.', MaxI, Max);
  
  Found := false;
  for var i := 0 to N - 1 do
    if (MaxI <> i) and (Max = A[i].Dist) then
      WritelnFormat('Точка {0} также далека как дальняя от начала координат.', i);
  if not Found then Writeln('Более дальних точек не обнаружено.');
end.

Сортировка треугольников по возрастанию периметра

[править]
const
  N = 3;

type
  TPoint = record
    X, Y: integer;
    
    constructor(px, py: integer);
    begin
      X := px;Y := py;
    end;
  end;
  
  TTriangle = record
    A, B, C: TPoint;
    P: real;
    
    constructor(pA, pB, pC: TPoint);
    begin
      A := pA;B := pB;C := pC;
    end;
  end;

function ReadlnPoint()  := new TPoint(ReadlnInteger('X:'), ReadlnInteger('Y:'));

function Distance(pA, pB: TPoint) := Sqrt(Sqr(pA.X - pB.X) + Sqr(pA.Y - pB.Y));

function PointToString(p: TPoint) := Format('({0}, {1})', p.X, p.Y);

function TriangleToString(t: TTriangle) := Format('Triangle: A{0}, B{1}, C{2}, P = {3}.', PointToString(t.A), PointToString(t.B), PointToString(t.C), t.P);

var
  A: array [0..N - 1] of TTriangle;

begin
  for var i := 0 to N - 1 do
  begin
    Writeln('New triangle:');
    A[i] := new TTriangle(ReadlnPoint(), ReadlnPoint(), ReadlnPoint());
    A[i].P := Distance(A[i].A, A[i].B) + Distance(A[i].B, A[i].C) + Distance(A[i].C, A[i].A);
  end;
  
  for var i := 0 to N - 1 do
    for var j := i + 1 to N - 1 do
      if A[i].P > A[j].P then
        Swap(A[i], A[j]);
  
  for var i := 0 to N - 1 do
    Writeln(TriangleToString(A[i]));
end.

Дальние треугольники

[править]
const
  N = 6;

type
  TPoint = auto class
    X, Y: real;
  end;

var
  L: List<(TPoint, TPoint, TPoint)>;
  Max: real;
  i1, i2: integer;

begin
  L := new List<(TPoint, TPoint, TPoint)>();
  
  for var i := 1 to N do
    L.Add((new Point(ReadlnInteger('X1:'), ReadlnInteger('Y1:')),
           new Point(ReadlnInteger('X2:'), ReadlnInteger('Y2:')),
           new Point(ReadlnInteger('X3:'), ReadlnInteger('Y3:'))
          ));
  
  Max := real.MinValue;
  for var i := 0 to N - 1 do
    for var j := i + 1 to N - 1 do
    begin
      var p1 := new TPoint((L[i].Item1.X + L[i].Item2.X + L[i].Item3.X) / 3,
                          (L[i].Item1.Y + L[i].Item2.Y + L[i].Item3.Y) / 3);
      var p2 := new TPoint((L[j].Item1.X + L[j].Item2.X + L[j].Item3.X) / 3,
                          (L[j].Item1.Y + L[j].Item2.Y + L[j].Item3.Y) / 3);                 
      var d := Sqrt(Sqr(p1.X - p2.X) + Sqr(p1.Y - p2.Y));
      if d > Max then
      begin
        i1 := i;
        i2 := j;
        Max := d;
      end;
    end;
  
  WritelnFormat('Индексы дальних треугольников: {0} и {1}.', i1, i2);
end.

Более сложные задачи

[править]

Конвертирование числа в строку

[править]
const
  S = '0123456789ABCDEF';

function ToString(a, base: integer): string;
begin
  while a <> 0 do
  begin
    Result := S.Chars[a mod base + 1] + Result;
    a := a div base;
  end;
end;

function ToStringRecursive(a, base: integer): string;
begin
  if a <> 0 then
    Result := S.Chars[a mod base + 1] + Result
  else
    Result := ToString(a div base, base);
end;

begin
  Writeln(ToString(15, 2) = ToStringRecursive(15, 2));
end.

Задача о детях

[править]
const
  N = 3;

type
  TPerson = auto class
    Surname, Name: string;
    Year: integer;
    Mass, Height: integer;
  end;

var
  A: array of TPerson;

begin
  SetLength(A, N);
  for var i := 0 to N - 1 do
  begin
    var p := ReadlnString().ToWords();
    A[i] := new TPerson(p[0], p[1], StrToInt(p[2]), StrToInt(p[3]), StrToInt(p[4]));
  end;
  
  A.Where(x -> begin
                 var d := 2017 - x.Year;
                 Result := (d >= 10) and (d <= 12) and (x.Height >= 155) and (x.Mass <= 45)
               end).Select(x -> Format('{0} {1} {2} {3} {4}', x.Surname, x.Name, x.Year, x.Mass, x.Height)).Println();
end.

Потенциальные друзья

[править]

Школа юных программистов решила разработать собственную социальную сеть, которая должна автоматически подбирать для каждого пользователя потенциальных друзей. При регистрации каждому пользователю сети предлагается пройти психологическое тестирование, по результатам которого определяются значения трёх психологических характеристик этого пользователя. Значение каждой характеристики — целое положительное число.

Считается, что если у двух пользователей различаются значения всех трёх психологических характеристик, то они будут постоянно ссориться, а если совпадают значения двух или трёх характеристик, то им будет скучно. Таким образом, потенциальными друзьями являются только такие пары пользователей, у которых совпадают значения ровно одной характеристики, а значения двух других — различаются.

Требуется написать программу, которая по данным тройкам значений характеристик каждого из пользователей определяет количество пар потенциальных друзей. 

var
  A: array of (integer, integer, integer);
  Count: integer;
 
begin
  SetLength(A, ReadlnInteger('Количество людей:'));
  for var i := 0 to A.Length - 1 do
  begin
    var p := ReadlnString().ToWords().ConvertAll(x -> StrToInt(x));
    A[i] := (p[0], p[1], p[2]);
  end;
  
  for var i := 0 to A.Length - 1 do
    for var j := i + 1 to A.Length - 1 do
      if Ord(A[i].Item1 = A[j].Item1) + Ord(A[i].Item2 = A[j].Item2) + Ord(A[i].Item3 = A[j].Item3) = 1 then
        Inc(Count);
  
  Writeln(Count);
end.

//Аналог через готовые методы.
begin
  var A := Range(1, ReadlnInteger('Количество людей')).Select(i -> ReadlnString().ToIntegers()).ToArray();
  Writeln(A.Cartesian(A, (v, t) -> Ord(v[0] = t[0]) + Ord(v[1] = t[1]) + Ord(v[2] = t[2])).Count(v -> v = 1) div 2);
end.

Хорошисты и отличники

[править]

Вывести фамилии и имена студентов, сдавших 3 экзамена на 4 или 5. 

type
  TAssessments = (integer, integer, integer, integer);
  TStatement = record
    Surname, Name: string;
    Assessments: TAssessments;
    
    constructor(s, n: string; a: TAssessments);
    begin
      Surname := s;Name := n;
      Assessments := a;
    end;
  end;
 
var
  L: List<TStatement>;
 
function F(a: integer) := (a = 4) or (a = 5);
 
begin
  L := new List<TStatement>();
  
  for var i := 0 to ReadlnInteger('N:') - 1 do
  begin
    var p := ReadlnString().ToWords();
    var k := p.Skip(2).ToList().ConvertAll(x -> StrToInt(x));
    L.Add(new TStatement(p[0], p[1], (k[0], k[1], k[2], k[3])));
  end;
  
  Writeln('Сдали 3 экзамена на 4 или 5:');
  L.Where(x -> Ord(F(x.Assessments.Item1)) + Ord(F(x.Assessments.Item2)) + Ord(F(x.Assessments.Item3)) + Ord(F(x.Assessments.Item4)) = 3).
  Select(x -> Format('{0} {1}', x.Surname, x.Name)).JoinIntoString(NewLine).Println();
  
  Writeln('Не сдали экзамены:');
  L.Where(x -> (x.Assessments.Item1 < 3) or (x.Assessments.Item2 < 3) or (x.Assessments.Item3 < 3) or (x.Assessments.Item4 < 3)).
  Select(x -> Format('{0} {1}', x.Surname, x.Name)).JoinIntoString(NewLine).Println();
end.
Источник — https://ru.wikibooks.org/w/index.php?title=Книга_программиста/Задачи_на_PascalABC.Net&oldid=231330