Задача про линию шариков (удаление со сдвигом 3х и более одинаковых подряд идущих)

@ivan8 · Регистрация: 08.10.2011

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

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

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

Формат входного файла

Даны количество шариков в цепочке (не более 1000) и цвета шариков (от 0 до 9, каждому цвету
соответствует свое целое число).

Формат выходного файла

Требуется вывести количество шариков, которое будет уничтожено.

Пример: ввод: 10 3 3 2 1 1 1 2 2 3 3 вывод: 10

@Puporev · 08.10.2011, 12:38

На файлы сами переделывайте.

Pascal

uses crt;
const nmax=30;
var a:array[1..nmax] of integer;
    n,i,j,k,p,s,q,ud:integer;
    f:boolean;
begin
clrscr;
repeat
write('Размер массива до ',nmax,' n=');
readln(n);
until n in [1..nmax];
writeln('Введите элементы массива:');
for i:=1 to n do
 begin
  write('a[',i,']=');
  readln(a[i]);
 end;
clrscr;
writeln('Исходный массив:');
for i:=1 to n do
write(a[i],' ');
writeln;
f:=false;{нет цепочек >2 элемента}
repeat
i:=2;{начнем со 2}
while i<=n do
if a[i]=a[i-1] then{если одинаковые}
 begin
  j:=i;
  s:=1;
  p:=i-1;{начало цепочки}
  while(j<=n) and(a[j]=a[j-1]) do
   begin
    s:=s+1;{считаем количество}
    j:=j+1;
   end;
  if s>2 then{если больше 2, удаляем}
   begin
    ud:=ud+s;{считаем сколько удалили}
    f:=true;
    for j:=1 to s do{s раз}
     begin
      for q:=p to n-1 do
      a[q]:=a[q+1];{сдвигаем конец массива влево на 1}
      n:=n-1;
     end
   end
  else i:=i+1;{если 2, то дальше}
 end
else i:=i+1;{если 1, то дальше}
until(n<3)or not f;{если осталось меньше 3 или нет цепочек}
writeln('Удалено ',ud,' элементов');
if n>0 then
 begin
  writeln('Массив после сжатия:');
  for i:=1 to n do
  write(a[i]:3);
 end;
readln
end.

@ivan8 · 08.10.2011, 13:06 **[ТС]**

Вроде всё так, но тестирующая система, в которую я сдаю, не принимает, + вывести надо только кол-во уничтоженных шариков, без самих массивов, но эт я подправил

Delphi

program d2;
const nmax=1000;
var a:array[1..nmax] of integer;
    n,i,j,p,s,q,ud:integer;
    f:boolean;
begin
ud:=0;
readln(n);
for i:=1 to n do readln(a[i]);
writeln;
f:=false;
repeat
i:=2;
while i<=n do
if a[i]=a[i-1] then
 begin
  j:=i;
  s:=1;
  p:=i-1;
  while(j<=n) and(a[j]=a[j-1]) do
   begin
    s:=s+1;
    j:=j+1;
   end;
  if s>2 then
   begin
    ud:=ud+s;
    f:=true;
    for j:=1 to s do
     begin
      for q:=p to n-1 do
      a[q]:=a[q+1];
      n:=n-1;
     end
   end
  else i:=i+1;
 end
else i:=i+1;
until(n<3)or not f;
writeln(ud);
end.

на считывание и выод не обращайте внимания (такое считывание и вывод система принимает)

@Puporev · 08.10.2011, 13:15

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

но тестирующая система, в которую я сдаю, не принимает,

И что пишет?

Добавлено через 23 секунды
На каком тесте?

@ivan8 · 08.10.2011, 13:16 **[ТС]**

Wrong answer (test 1)

@Puporev · 08.10.2011, 13:19

Я не знаю, сколько вариантов вводил, все работают, в том числе и тот что в первом посте.

@ivan8 · 08.10.2011, 13:24 **[ТС]**

А в моем (т.е. вашем, чуть-чуть измененном) коде есть какие либо ошибки? И работоспособен ли он на delphi?

@Puporev · 08.10.2011, 13:30

Я его запускал пару раз, ошибок не нашел. В консоли Делфи тоже должен работать.

Добавлено через 3 минуты
В Делфи

Delphi

program Project2;
 
{$APPTYPE CONSOLE}
 
uses
  SysUtils;
 
const nmax=1000;
var a:array[1..nmax] of integer;
    n,i,j,p,s,q,ud:integer;
    f:boolean;
begin
ud:=0;
readln(n);
for i:=1 to n do readln(a[i]);
writeln;
f:=false;
repeat
i:=2;
while i<=n do
if a[i]=a[i-1] then
 begin
  j:=i;
  s:=1;
  p:=i-1;
  while(j<=n) and(a[j]=a[j-1]) do
   begin
    s:=s+1;
    j:=j+1;
   end;
  if s>2 then
   begin
    ud:=ud+s;
    f:=true;
    for j:=1 to s do
     begin
      for q:=p to n-1 do
      a[q]:=a[q+1];
      n:=n-1;
     end
   end
  else i:=i+1;
 end
else i:=i+1;
until(n<3)or not f;
writeln(ud);
readln
end.

@ivan8 · 08.10.2011, 15:42 **[ТС]**

Да, на компьютере все работает (только readln на read поменял ибо во входных там всё в одной строчке).
Станная система вообще.
Спасибо вам еще раз, буду разбираться.

Добавлено через 2 часа 0 минут
Puporev, например при входных данных 6 1 1 1 2 2 2 программа не работает

@Puporev · 08.10.2011, 15:48

У меня работает, выдает ответ=6

Добавлено через 31 секунду
Проверял на твоем коде в посте номер 3.

@ivan8 · 08.10.2011, 15:50 **[ТС]**

Проверял в паскалее или в делфи?

@Puporev · 08.10.2011, 15:58

ivan8, Я же написал как проверял, читай хоть.

Добавлено через 2 минуты
Да и какая разница в чес, алгоритм же не меняется.

@ivan8 · 08.10.2011, 16:06 **[ТС]**

ерунда какая-то
делфи то на read вместо readln ругается, то на ud:=0, то на readln в конце

@Puporev · 08.10.2011, 16:10

У меня ни на что не ругается.

Добавлено через 1 минуту
ты что, переписываешь что ли код? Скопируй, в окне проекта все удали, а этот код вставь.

@ivan8 · 08.10.2011, 16:19 **[ТС]**

Puporev, 13 1 2 2 2 1 1 3 3 3 3 3 3 3

Delphi

program a1;
{$APPTYPE CONSOLE}
 
uses
  SysUtils;
 
const nmax=1000;
var a:array[1..nmax] of integer;
    n,i,j,p,s,q,ud:integer;
    f:boolean;
begin
ud:=0;
read(n);
for i:=1 to n do read(a[i]);
writeln;
f:=false;
repeat
i:=2;
while i<=n do
if a[i]=a[i-1] then
 begin
  j:=i;
  s:=1;
  p:=i-1;
  while(j<=n) and(a[j]=a[j-1]) do
   begin
    s:=s+1;
    j:=j+1;
   end;
  if s>2 then
   begin
    ud:=ud+s;
    f:=true;
    for j:=1 to s do
     begin
      for q:=p to n-1 do
      a[q]:=a[q+1];
      n:=n-1;
     end
   end
  else i:=i+1;
 end
else i:=i+1;
until(n<3)or not f;
writeln(ud);
readln;
readln;
end.

синим выделяет for q:=p to n-1 do

Добавлено через 31 секунду
а так всё нормально

Добавлено через 2 минуты
и попрежнему Wrong answer (test 1)

@Puporev · 08.10.2011, 16:22

Ничего у меня не выделят, ответ = 13.

@ivan8 · 08.10.2011, 16:32 **[ТС]**

С переменным успехом у меня.

Система не принемает всё равно, очень станно.

Обидно, все 20 задач решил, а последняя 21 вот.

@Puporev · 08.10.2011, 16:55

Это она специально, нельзя все решать...

Добавлено через 16 минут
А там как, ты просто отправляешь код программы и все?

@ivan8 · 08.10.2011, 21:59 **[ТС]**

Puporev, да.
Я кстати нашел "ошибку": "лишний" writeln.
Теперь правда говорит Time limit exceeded (test 8)

@Puporev · 09.10.2011, 08:57

Я тоже нашел, не туда строчку вставил, нужно

Pascal

for i:=1 to n do read(a[i]);
writeln;
repeat
i:=2;
f:=false;//вот сюда нужно
while i<=n do

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 16:10	14
	У меня ни на что не ругается. Добавлено через 1 минуту ты что, переписываешь что ли код? Скопируй, в окне проекта все удали, а этот код вставь. 1

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 16:32 [ТС]	17
	С переменным успехом у меня. Система не принемает всё равно, очень станно. Обидно, все 20 задач решил, а последняя 21 вот. 0

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 16:55	18
	Это она специально, нельзя все решать... Добавлено через 16 минут А там как, ты просто отправляешь код программы и все? 0

Задача про линию шариков (удаление со сдвигом 3х и более одинаковых подряд идущих)

Решение

Решение

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 13:15	4
	Сообщение от ivan8 но тестирующая система, в которую я сдаю, не принимает, И что пишет? Добавлено через 23 секунды На каком тесте? 1

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 13:16 [ТС]	5
	Wrong answer (test 1) 0

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 13:19	6
	Я не знаю, сколько вариантов вводил, все работают, в том числе и тот что в первом посте. 1

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 13:24 [ТС]	7
	А в моем (т.е. вашем, чуть-чуть измененном) коде есть какие либо ошибки? И работоспособен ли он на delphi? 0

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 15:42 [ТС]	9
	Да, на компьютере все работает (только readln на read поменял ибо во входных там всё в одной строчке). Станная система вообще. Спасибо вам еще раз, буду разбираться. Добавлено через 2 часа 0 минут Puporev, например при входных данных 6 1 1 1 2 2 2 программа не работает 0

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 15:48	10
	У меня работает, выдает ответ=6 Добавлено через 31 секунду Проверял на твоем коде в посте номер 3. 0

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 15:50 [ТС]	11
	Проверял в паскалее или в делфи? 0

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 15:58	12
	ivan8, Я же написал как проверял, читай хоть. Добавлено через 2 минуты Да и какая разница в чес, алгоритм же не меняется. 1

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 16:06 [ТС]	13
	ерунда какая-то делфи то на read вместо readln ругается, то на ud:=0, то на readln в конце 0

@Puporev Почетный модератор 64288 / 47587 / 32739 Регистрация: 18.05.2008 Сообщений: 115,182
	08.10.2011, 16:22	16
	Ничего у меня не выделят, ответ = 13. 1

@ivan8 1 / 1 / 0 Регистрация: 08.10.2011 Сообщений: 13
	08.10.2011, 21:59 [ТС]	19
	Puporev, да. Я кстати нашел "ошибку": "лишний" writeln. Теперь правда говорит Time limit exceeded (test 8) 0