Стандартные операции с массивами (матрицами)

@Unrealler · Регистрация: 11.12.2009

Студворк — интернет-сервис помощи студентам

-------------------------------------------------------------------------------------------
Содержание:

-------------------------------------------------------------------------------------------

1) Очень часто на форуме просят "переворот" массива. Например, было

Code
1
1 2 3 4 5

Стало

Code
1
5 4 3 2 1

Осуществляется это так:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
var
   a:array[1..100] of integer;
   i,r,n:integer;
begin
 readln(n); {читаем размер массива}
 for i:=1 to n do
  read(a[i]);
 for i:=1 to n div 2 do   {сам "переворот"}
  begin
   r:=a[i];
   a[i]:=a[n-i+1];
   a[n-i+1]:=r;
  end;
 for i:=1 to n do
  write(a[i],' ');
 readln
end.

2) Не менее возникает вопрос о сдвиге массива на k элементов влево или вправо.
Было

Code
1
1 2 3 4 5

Стало

Code
1
5 1 2 3 4

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

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
var
   a:array[1..100] of integer;
   i,r,n,k,j:integer;
begin
 read(n,k);  {k обозначает величину сдвига}
 for i:=1 to n do
  read(a[i]);
 for i:=1 to k do
  begin
   for j:=1 to n do
    if (j=1) then r:=a[j] else a[j-1]:=a[j];
   a[n]:=r;
  end;
 for i:=1 to n do
  write(a[i],' ');
 readln
end.

Сдвиг на k элементов вправо:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
var
   a:array[1..100] of integer;
   i,r,n,k,j:integer;
begin
 read(n,k);  {k обозначает величину сдвига}
 for i:=1 to n do
  read(a[i]);
 for i:=1 to k do
  begin
   for j:=n downto 1 do
    if (j=n) then r:=a[n] else a[j+1]:=a[j];
   a[1]:=r;
  end;
 for i:=1 to n do
  write(a[i],' ');
 readln
end.

@yanyk1n · 29.05.2010, 13:20

3) Поиск минимума/максимума и их индексов:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
var a:array[1..100]of integer;
N,i,min,max:integer;
 
begin
 write('N -> ');
 readln(N); {считываем размер массива}
 write('Input array -> ');
 for i:=1 to N do read(a[i]); {считываем сам массив}
 readln;
 min:=1;
 max:=2;
 for i:=1 to N do if a[i] > a[max] then max:=i else if a[i] < a[min] then min := i;
 writeln('MAX = A[',max,'] = ', a[max]);
 writeln('MIN = A[',min,'] = ', a[min]);
 readln;
end.

4) Поиск минимума/максимума и их индексов в двумерном массиве (матрице):

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
var a:array[1..100,1..100]of integer;
N, M, i, j, mini, minj, maxi, maxj :integer;
 
begin
 write('N, M -> ');
 readln(N, M); {считываем размер матрицы}
 write('Input matrix -> ');
 for i:=1 to N do for j:=1 to M do
 begin
  write('A[',i,',',j,'] -> ');
  readln(a[i, j]);
 end; {считываем саму матрицу}
 readln;
 mini:=1;
 minj:=1;
 maxi:=2;
 maxj:=2;
 for i:=1 to N do for j:=1 to M do if a[i,j] > a[maxi, maxj] then
 begin
  maxi := i;
  maxj := j;
 end else if a[i, j] < a[mini, minj] then
 begin
  mini := i;
  minj := j;
 end;
 writeln('MAX = A[',maxi,',',maxj,'] = ', a[maxi, maxj]);
 writeln('MIN = A[',mini,',',minj,'] = ', a[mini, minj]);
 readln;
end.

5) Работа с элементами выше/ниже/на главной/побочной диагоналях

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
var a:array[1..100,1..100]of integer;
N, M, i, j :integer;
 
begin
 write('N, M -> ');
 readln(N, M); {считываем размер матрицы}
 write('Input matrix -> ');
 for i:=1 to N do for j:=1 to M do
 begin
  write('A[',i,',',j,'] -> ');
  readln(a[i, j]);
 end; {считываем саму матрицу}
 readln;
 
 writeln('Главная диагональ');
 for i:=1 to N do
 begin
  write(a[i,i],' '); {вы можете не только просто выводить элементы, но и работать с ними. Достаточно знать индексацию нужных элементов}
 end;
 writeln;
 
 writeln('Побочная диагональ');
 for i:=1 to N do
 begin
  write(a[i,N-i+1],' ');
 end;
 writeln;
 
 writeln('Ниже главной');
 for i:=2 to N do
 for j:=1 to i-1 do
 begin
  write(a[i,j],' ');
 end;
 writeln;
 
 writeln('Выше главной');
 for i:=1 to N-1 do
 for j:=i+1 to N do
 begin
  write(a[i,j],' ');
 end;
 writeln;
 
 writeln('Выше побочной');
 for i:=1 to N-1 do
 for j:=1 to N-i do
 begin
  write(a[i,j],' ');
 end;
 writeln;
 
 writeln('Ниже побочной');
 for i:=2 to N do
 for j:=N-i+2 to N do
 begin
  write(a[i,j],' ');
 end;
 writeln;
 readln;
end.

@STGE · 29.05.2010, 23:14

6) Транспонирование матрицы относительно главной и побочной диагоналей (заполнение матрицы осуществляется посредством генератора случайных чисел):

а) главная диагональ:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 {транспонирование матрицы относительно главной диагонали}
 uses crt;
 const n=100;
 var mas: array[1..n,1..n] of integer;
     i,j,l: byte;  prom: integer;
 begin
 
  randomize;   {процедура инициализации генератора случайных чисел}
  clrscr;
 
  write('введите размер матрицы: ');   {ввод размеров матрицы}
  readln(l);
  writeln;
 
  writeln('исходная матрица: ');    {вывод исходной матрицы на экран}
  for i:=1 to l do
   begin
    for j:=1 to l do
     begin
      mas[i,j]:=random(19);
      mas[i,j]:=mas[i,j]-9;
      write(mas[i,j]:3);
     end;
    writeln;
   end;
  writeln;
 
  for i:=2 to l do   {сам процесс транспонирования}
   for j:=1 to i-1 do
    begin
     prom:=mas[i,j];
     mas[i,j]:=mas[j,i];
     mas[j,i]:=prom;
    end;
 
  writeln('результат транспонирования: ');    {вывод матрицы после преобразований}
  for i:=1 to l do
   begin
    for j:=1 to l do
     write(mas[i,j]:3);
    writeln;
   end;
 
 end.

б) побочная диагональ:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 {транспонирование матрицы относительно побочной диагонали}
 uses crt;
 const n=100;
 var mas: array[1..n,1..n] of integer;
     i,j,l: byte; prom: integer;
 begin
 
  randomize;   {процедура инициализации генератора случайных чисел}
  clrscr;
 
  write('введите размер матрицы: ');   {ввод размеров матрицы}
  readln(l);
  writeln;
 
  writeln('исходная матрица: ');    {вывод исходной матрицы на экран}
  for i:=1 to l do
   begin
    for j:=1 to l do
     begin
      mas[i,j]:=random(19);
      mas[i,j]:=mas[i,j]-9;
      write(mas[i,j]:3);
     end;
    writeln;
   end;
  writeln;
 
  for i:=1 to l-1 do   {сам процесс транспонирования}
   for j:=l-i downto 1 do
    begin
     prom:=mas[i,j];
     mas[i,j]:=mas[l-j+1,l-i+1];
     mas[l-j+1,l-i+1]:=prom;
    end;
 
  writeln('результат транспонирования: ');  {вывод матрицы после преобразований}
  for i:=1 to l do
   begin
    for j:=1 to l do
     write(mas[i,j]:3);
    writeln;
   end;
 
 end.

@Unrealler · 31.05.2010, 08:56 **[ТС]**

7) Это довольно нестандартная операция, но все же может пригодится.
Поворот двумерного массива на 90° по часовой стрелке. Выглядит это так:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
var
   a,b:array[1..100,1..100] of integer;
   i,j,n,m:integer;
begin
 readln(n,m);    {количество строк и столбцов соответственно}
 for i:=1 to n do
  for j:=1 to m do
   read(a[i,j]);     {считываем элементы}
 writeln('Старый массив');
 for i:=1 to n do
  begin
   for j:=1 to m do
    write(a[i,j]:4); {вывод введенного массива на экран}
   writeln;
  end;
 for j:=1 to n do
  for i:=1 to m do
b[i,n-j+1]:=a[j,i];  {переворот массива осуществляется при помощи другого массива}
 writeln('Новая размерность');
 writeln(m,' ',n);  {выводим новые размеры}
 writeln('Новый массив');
 for i:=1 to m do
  begin
   for j:=1 to n do
    write(b[i,j]:4);   {выводим новый массив}
   writeln;
  end;
 readln
end.

@Puporev · 31.05.2010, 11:22

8) Поворот на 90 градусов по часовой стрелке и против без использования дополнительного массива.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
uses crt;
const n=6;
var a : array[1..n,1..n] of integer;
    i,j,p,x : integer;
begin
clrscr;
writeln('Исходная матрица:');
for i:=1 to n do
  begin
    for j:=1 to n do
      begin
       a[i,j] := 10*i+j;
       write(a[i,j]:4);
      end;
    writeln;
  end;
p := n div 2;
{поворот по часовой стрелке}
for i:=1 to p do
for j:=i to n-i do
  begin
    x := a[i,j];
    a[i,j] := a[n-j+1,i];
    a[n-j+1,i] := a[n-i+1,n-j+1];
    a[n-i+1,n-j+1] := a[j,n-i+1];
    a[j,n-i+1] := x;
  end;
writeln('Поворот на 90 градусов по часовой стрелке:');
for i:=1 to n do
  begin
    for j:=1 to n do
    write(a[i,j]:4);
    writeln;
  end;
{поворот против часовой стрелки}
for i:=1 to p do
for j:=i to n-i do
 begin
  x:=a[i,j];
  a[i,j]:=a[j,n-i+1];
  a[j,n-i+1]:=a[n-i+1,n-j+1];
  a[n-i+1,n-j+1] := a[n-j+1,i];
  a[n-j+1,i]:=x;
 end;
writeln('Поворот на 90 градусов против часовой стрелки:');
for i:=1 to n do
  begin
    for j:=1 to n do
    write(a[i,j]:4);
    writeln;
  end;
readln
end.

@Unrealler · 01.06.2010, 08:54 **[ТС]**

9) Удаление элемента в одномерном массиве
Пусть нужно удалить все нулевые элементы из введенного пользователем массива.
Удаление:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
var
   a:array[1..100] of integer;
   i,m,n:integer;
begin
 readln(n);    {считываем количество элементов}
 for i:=1 to n do
  read(a[i]);
 writeln('Массив');
 for i:=1 to n do
  write(a[i],' ');
 writeln;
 writeln('После удаления');
 m:=0;
 for i:=1 to n do
  if (a[i]=0) then inc(m) else a[i-m]:=a[i]; {удаляем элементы}
 dec(n,m);  {уменьшаем количество элементов массива на количество нулевых элементов}
 for i:=1 to n do
  write(a[i],' '); {вывод на экран}
 readln
end.

@Unrealler · 02.06.2010, 12:44 **[ТС]**

10) Вставка элемента в одномерный массив

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
var
   a:array[1..100] of integer;
   i,x,n,nom:integer;
begin
 write('Введите количество элементов=');
 readln(n);
 for i:=1 to n do
  read(a[i]);  {считываем элементы}
 write('Введите число, которое нужно вставить=');
 readln(x);
 write('Введите номер ячейки, в которую его надо поместить=');
 readln(nom);
 writeln('Массив');
 for i:=1 to n do
  write(a[i],' ');
 writeln;
 writeln('После вставки');
 for i:=n+1 downto nom+1 do
  a[i]:=a[i-1]; {сдвигаем все элементы вправо}
 a[nom]:=x;    {вставляем число}
 for i:=1 to n+1 do
  write(a[i],' ');
 readln
end.

@Unrealler · 02.07.2010, 16:24 **[ТС]**

11) Цифровая сортировка (DigidalSort)
Пусть нужно отсортировать массив по возрастанию, а на вход поступают числа в диапазоне [-100;100]. При этом их количество настолько большое, что не поможет даже быстрая сортировка. Выходом служит так называемая цифровая сортировка. Возьмем

Pascal
1
a:array[-100..100] of integer

Предварительно обнулим его.

Pascal
1
2
for i:=-100 to 100 do
 a[i]:=0;

Или

Delphi
1
fillchar(a,sizeof(a),0)

для пишущих на Delphi
Каждая ячейка a[i] будет хранить количество повторений числа i
Получаем:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
var
   a:array[-100..100] of integer;
   i,n,c,j:integer;
begin
 readln(n);
 for i:=1 to n do
  begin
   read(c);
   inc(a[c]);
  end;
 for i:=-100 to 100 do
  for j:=1 to a[i] do
   write(i,' ');
 readln
end.

@Puporev · 06.11.2010, 09:02

Удаление всех строк и столбцов, содержащих хоть 1 ноль. Также положительные, отрицательные и т.д.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
uses crt;
var a:array[1..10,1..9] of integer;
    b:array[1..9] of byte;
    m,n,i,j,f,p,k:byte;
begin
clrscr;
randomize;
n:=10;
m:=9;
writeln('Исходная матрица:');
for i:=1 to n do
 begin
  for j:=1 to m do
   begin
    a[i,j]:=random(10);
    write(a[i,j]:3);
   end;
  writeln;
 end;
writeln;
{номера столбцов с нолями}
f:=0;
for j:=1 to m do
 begin
  k:=0;
  for i:=1 to n do
  if a[i,j]=0 then
   begin
    k:=1;
    f:=1;
   end;
  b[j]:=k;
 end;
if f=0 then write('В матрице нет нолей!')
else
 begin
  {удаление строк с нолем}
  i:=n;{начнем с конца}
  while(i>=1)and(n>0) do
   begin
    k:=0;
    j:=1;
    while(j<=m)and(k=0) do
    if a[i,j]=0 then k:=1
    else j:=j+1;
    if k=1 then{если есть ноль}
     begin
      f:=f-1;{вычитаем строку}
      if i=n then {если строка на этот момент последняя}
       begin
        n:=n-1;{обрезаем}
        i:=i-1;{верх}
       end
      else {если не последняя}
       begin
        for k:=i to n-1 do{от этой строки до предпоследней}
        for p:=1 to m do{всем элементам строк}
        a[k,p]:=a[k+1,p];{присваиваем значения нижней}
        n:=n-1;{уменьшаем количество}
       end;
     end
    else i:=i-1;{если нет нолей, вверх}
   end;
if n=0 then writeln('Все строки и столбцы удалены!')
else{если остались строки, удаляем столбцы}
 begin
  f:=m;{начнем с конца}
  for i:=m downto 1 do{в обратном порядке читаем массив номеров}
  if b[i]=1 then{если есть ноль}
   begin
    if i=f then{и последний на данный момент, также как строки}
      begin
       m:=m-1;
       f:=f-1;
      end
    else {если не последний, тоже как строки}
     begin
      for k:=i to m-1 do
      for p:=1 to n do
      a[p,k]:=a[p,k+1];
      m:=m-1;
     end;
   end;
  writeln('Матрица после сжатия:');
  for i:=1 to n do
   begin
    for j:=1 to m do
    write(a[i,j]:3);
    writeln;
   end;
 end;
 end;
readln
end.

@Домолаз · 11.12.2010, 17:48

Двоичный(бинарный) поиск
Ищет номер заданного элемента в упорядоченном по возрастанию массиве.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
var
   n,v,i,r:integer;
   a:array[1..1000] of integer;
   
procedure binsearch(left,right:integer);
begin
    if left=right then
    begin
       r:=right;
       exit;
    end;
      
   r:=(right+left) div 2;
   if a[r]<v then
   begin
      left:=r+1;
      binsearch(left,right)
   end
   else
   begin
      right:=r;
      binsearch(left,right);
   end;
end;
 
begin
   readln(n);
   for i:=1 to n do
      read(a[i]);
   readln(v);
   binsearch(1,n);
   if a[r]=v then
      writeln(r)
   else
      writeln('Absent');
end.

@TAVulator · 02.03.2011, 23:49

Все знают как работать с двумерными массивами с помощью двух циклов:

Pascal
1
2
3
For i:=1 to N do
 For j:=1 to M do
  A[i,j] ...

А что если осуществить работу с матрицей в одном цикле? Легко!
Достаточно реализовать цикл от 0 до кол-во элементов -1.
Обращение к элементу осуществляется по формуле:
A[(i div кол-во строк)+1, (i mod кол-во столбцов)+1]

Пример реализации:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
const
 N = 7; {кол-во строк}
 M = 6; {кол-во столбцов}
var
 A: array[1..N,1..M] of byte;
 i: byte;
Begin
 Randomize;
 For i:=0 to N*M-1 do
  Begin
   A[(i div N)+1, (i mod M)+1]:=random(99);
   write(A[(i div N)+1, (i mod M)+1]:4);
   if ((i+1) mod M = 0) then writeln;
  End;
 readln;
End.

@Cegou · 05.03.2011, 15:52

Хотелось бы добавить способ заполнения массива случайными неповторяющимися числами:

для одномерного:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
var
  a: array [1..100] of integer;
  i, j, k, n: integer;
 
begin
  repeat
    write('Задайте размер массива: ');
    readln(n);
  until n in [1..100];
  writeln('Массив:');
  for i := 1 to n do
  begin
    repeat
      k := 0;
      a[i] := random(-101, 101);
      for j := 1 to i - 1 do
        if a[j] = a[i] then inc(k);
    until k = 0;
    write(a[i], ' ');
  end;
  writeln;
end.

для двумерного:

@Puporev · 05.03.2011, 16:03

Pascal
1
random(-101, 101)

;
Вроде так не бывает...
обычно random(203)-101;

@Cegou · 05.03.2011, 16:19

В abc.net такая конструкция, допустима

Но в этом топике надо писать обобщенно, согласен.

Наверно вечерком закину для двумерного)

@Puporev · 05.03.2011, 16:54

В abc.net такая конструкция, допустима

Здесь наверное ты один в этом пишешь, придерживайся общих правил Паскаля.

@S9 · 02.06.2011, 08:55

Если кому надо, то вот два варианта заполнения двухмерного массива.
Этот код заполняет как на картинке 1

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Const
    N = 5;
Var
    A:Array[1..20,1..20] Of Integer;
    k,x,y,Num:integer;
  {проверка диапазона}
  
Procedure Check(Var i,j:Integer);
    Begin
      If i = 0 Then Inc(i)
        Else
          If i > N Then
            Begin
              i:= N;
              j:= j+2;
            End;
    End;
    
Begin
    {начальные значиения}
    x:=1;
    y:=1;
    k:=1;
    {перебираем все номера}
    For Num:=1 To N*N Do
        Begin
            A[x,y]:=Num;
            {следующие координаты}
            x:=x + k;
            y:=y - k;
        {сдедующая строка эквивалентна 
        if (x = 0)Or(y = 0)Or(x > N)Or(y > N) Then k:=-k;}
        k:=k*(1 - 2*Ord((x = 0)Or(y = 0)Or(x > N)Or(y > N)));
        {корректируем координаты}
        If Odd(N) Then
            Begin
                Check(x,y);
                Check(y,x);
            End
                Else
            Begin
                Check(y,x);
                Check(x,y);
            End;
        End;{выводим результат}
    For x:=1 To N Do
        Begin
            For y:=1 To N Do
                Write(a[x,y]:3);
            WriteLn;
        End;
    ReadLn;
End.

А этот, как на картинке 2

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Var A:Array[1..100,1..100] Of Integer;
    n,i,j:Integer;
    
Begin
Write('n = ');
ReadLn(n);
If n Mod 2 <> 0 Then {для матриц нечетной размерности}
For i:=1 To n Do
    Begin
        For j:=1 To n Do
        Begin
            If i Mod 2 <> 0 Then {для нечетных строк}
                A[i,j]:=n*(n - i) + j
            Else A[i,j]:=n*(n - i + 1) - j + 1; {для четных строк}
                Write(a[i,j]:3);
        End;
        WriteLn;
    End
Else 
    If n Mod 2 = 0 Then  {для матриц четной размерности}
For i:=1 To n Do
    Begin
    For j:=1 To n Do
        Begin
            If i Mod 2 <> 0 Then  { для нечетных строк } 
                A[i,j]:=n*(n - i + 1) - j + 1
            Else a[i,j]:=n*(n - i) + j;  { для четных строк }
                Write(a[i,j]:3);
        End;
        WriteLn;
    End;
ReadLn;
End.

22.06.2011, 15:44

может кто-нибудь организует все операции в процедуры? как вот здесь:
Сортировки

Добавлено через 41 минуту
а как совместить 4 и 5 пункт?

например найти минимум/максимум на главной/побочной или выше/ниже определённой диагонали?

да. я новичёк. учусь.

@XEHK · 07.07.2011, 23:06

Сообщение от Unrealler

9) Удаление элемента в одномерном массиве
Пусть нужно удалить все нулевые элементы из введенного пользователем массива.

а как удалить все елементи каторие встречаютса больше 1 гороза?

@Puporev · 08.07.2011, 08:34

как удалить все элементы, которые встречаются больше 1 раза?

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
uses crt;
var a:array[1..100] of integer;
    n,i,j,k,p,x:integer;
    f:boolean;
begin
clrscr;
randomize;
write('n=');readln(n);
writeln('Исходный массив:');
for i:=1 to n do
 begin
  a[i]:=random(10);
  write(a[i],' ');
 end;
writeln;
i:=1;
while i<n do
 begin
  f:=false;
  j:=i+1; //смотрим впереди
  while (j<=n)and not f do
  if a[j]=a[i] then  f:=true//если есть такой же, меняем флаг
  else j:=j+1; //иначе идем дальше
  if f then //если есть повторы
   begin
    x:=a[i];//запомним элемент
    p:=i;//и его текущую позицию
    while p<=n do //идем к концу
    if a[p]=x then //если такой же
     begin
      if p=n then n:=n-1 //если последний, убавляем размер массива
      else //иначе
       begin
        for k:=p to n-1 do //сдвигаем на него конец массива
        a[k]:=a[k+1];
        n:=n-1; //убавляем
       end
     end
    else p:=p+1;//если не такой, дальше
   end
  else i:=i+1;//если не удаляли, дальше
 end;
if n=0 then write('Все элементы более 1 раза, массив пустой')
else
 begin
  writeln('Более 1 раза удалены:');
  for i:=1 to n do
  write(a[i],' ');
 end;
readln
end.

@lamed · 14.07.2011, 20:21

Удаление элементов в одномерном несортированном массиве по условию (без сохранения порядка).

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
{ Сама задача. Алгоритмы. Введение в разработку и анализ. Ананий Левитин
Упражнения 1.4.1. Поясните, как можно реализовать каждую из перечисленных ниже 
операций над массивом так, чтобы время ее выполнения не зависело от
размера массива n. а) Удаление i-го элемента массива 1 <= i <= n). }
{ Усложненная модификация: удалить все элементы, которые делятся нацело на x }
{ PascalABC.NET. lamed, 14.07.2011 }
const
  MaxN = 30;
var
  a: array[1..MaxN] of integer;
  i, n: integer;
  x: integer;
  k: integer;
begin
  // Формирование одномерного массива
  randomize;
  n:=1+random(MaxN);
  for i:= 1 to n do
    a[i]:= random(MaxN+1);
    
  x:= 2+random(n-1);
  
  writeln('До обработки n=', n, '.');
  write('<');
  for i:= 1 to n do
    begin
      if i<>1 then write(',');
      write(a[i]);
    end;
  writeln('>');
 
  i:=1;
  k:= 0;
  while (i<=n) do
    begin
      while (i<=n) and (a[i] mod x=0) do
        begin // Если элемент требуется удалить
          a[i]:= a[n]; // Заменяем его последним использованным элементом массива
          // заменяющий элемент на следующем шаге тоже придется проверить
          dec(n); // уменьшаем счетчик числа используемых элементов
          inc(k); // увеличиваем счетчик удаленных элементов
        end;
      inc(i);
    end;
 
  writeln;
  writeln('n=', n, '. Удалено ', k, ' элементов, которые делятся на ', x, '.');
  write('<');
  for i:= 1 to n do
    begin
      if i<>1 then write(',');
      write(a[i]);
    end;
  writeln('>');
end.

Пример работы

Pascal
1
2
3
4
5
До обработки n=25.
<13,26,2,18,12,8,21,19,17,30,13,29,28,29,27,9,12,29,1,24,28,6,15,13,27>
 
n=23. Удалено 2 элементов, которые делятся на 14.
<13,26,2,18,12,8,21,19,17,30,13,29,27,29,27,9,12,29,1,24,13,6,15>

Новые блоги и статьи Все статьи Все блоги /
Использование SDL3-callbacks вместо функции main() на Android, Desktop и WebAssembly 8Observer8 24.01.2026 Если вы откроете примеры для начинающих на официальном репозитории SDL3 в папке: examples, то вы увидите, что все примеры используют следующие четыре обязательные функции, а привычная функция main(). . .	моя боль iceja 24.01.2026 Выложила интерполяцию кубическими сплайнами www. iceja. net REST сервисы временно не работают, только через Web. Написала за 56 рабочих часов этот сайт с нуля. При помощи perplexity. ai PRO , при. . .	Модель сукцессии микоризы anaschu 24.01.2026 Решили писать научную статью с неким РОманом	http://iceja.net/ математические сервисы iceja 20.01.2026 Обновила свой сайт http:/ / iceja. net/ , приделала Fast Fourier Transform экстраполяцию сигналов. Однако предсказывает далеко не каждый сигнал (см ограничения http:/ / iceja. net/ fourier/ docs ). Также. . .
http://iceja.net/ сервер решения полиномов iceja 18.01.2026 Выкатила http:/ / iceja. net/ сервер решения полиномов (находит действительные корни полиномов методом Штурма). На сайте документация по API, но скажу прямо VPS слабенький и 200 000 полиномов. . .	Расчёт переходных процессов в цепи постоянного тока igorrr37 16.01.2026 / * Дана цепь(не выше 3-го порядка) постоянного тока с элементами R, L, C, k(ключ), U, E, J. Программа находит переходные токи и напряжения на элементах схемы классическим методом(1 и 2 з-ны. . .	Восстановить юзерскрипты Greasemonkey из бэкапа браузера damix 15.01.2026 Если восстановить из бэкапа профиль Firefox после переустановки винды, то список юзерскриптов в Greasemonkey будет пустым. Но восстановить их можно так. Для этого понадобится консольная утилита. . .	Сукцессия микоризы: основная теория в виде двух уравнений. anaschu 11.01.2026 https:/ / rutube. ru/ video/ 7a537f578d808e67a3c6fd818a44a5c4/

@Cegou 37 / 32 / 9 Регистрация: 04.03.2011 Сообщений: 120
	05.03.2011, 16:19
	В abc.net такая конструкция, допустима Но в этом топике надо писать обобщенно, согласен. Наверно вечерком закину для двумерного) 0

Incred
	22.06.2011, 15:44
	может кто-нибудь организует все операции в процедуры? как вот здесь: Сортировки Добавлено через 41 минуту а как совместить 4 и 5 пункт? например найти минимум/максимум на главной/побочной или выше/ниже определённой диагонали? да. я новичёк. учусь.