Анка и Петька ждали Чапаева и ели картошку. Вскоре они наелись и решили поиграть в «Чапаева» оставшимися четырьмя картофелинами. Петька достал доску размером 20 × 20 клеток, положил на неё картофелины и сказал, что по правилам никакие две картофелины не могут находиться в одной клетке, а одной картофелиной можно сбить другую только в том случае, если они расположены на одной горизонтали или вертикали и между ними нет других картофелин. Анка предложила взять некоторые картофелины и поставить их на другие свободные клетки так, чтобы каждой картофелиной можно было сбить ровно одну другую. Помогите Петьке переставить как можно меньше картофелин, чтобы выполнить её просьбу. Исходные данные В четырёх строках записаны координаты картофелин xi, yi — целые числа в пределах от 1 до 20. Никакие две картофелины не расположены в одной клетке. Результат Выведите новые координаты картофелин. Картофелины следует описывать в том же порядке, в котором они заданы на входе. Если возможных ответов несколько, выведите любой.
{$APPTYPE CONSOLE} const c=4;m=20; type TPotate=record x,y,b:byte; end; var p:array[1..c] of TPotate; i,j,k,l:byte;
function bcount(x1,y1:byte):byte; var k,kx,ky:integer; begin result:=0;kx:=0;ky:=0; for k:=1 to c do with p[k] do begin if (x=x1) and (y<>y1) then begin case ky of 0:begin inc(result); if y1>y then ky:=1 else ky:=-1; end; 1:if y1<y then begin inc(result);ky:=2; end; -1:if y1>y then begin inc(result);ky:=2; end; end; end; if (x<>x1) and (y=y1) then begin case kx of 0:begin inc(result); if x1>x then kx:=1 else kx:=-1; end; 1:if x1<x then begin inc(result);kx:=2; end; -1:if x1>x then begin inc(result);kx:=2; end; end; end; end; end;
Function check:boolean; var k:byte; begin result:=true; for k:=1 to c do if p[k].b<>1 then begin result:=false; break; end; end;
function chklet(x2,y2:byte):boolean; var u:byte; begin result:=true; for u:=1 to c do if (p[u].x=x2) and (p[u].y=y2) then begin result:=false;break; end; end;
begin for i:=1 to c do with p[i] do begin b:=0;read(x,y);readln; end; for i:=1 to c do with p[i] do b:=bcount(x,y); while not(check) do begin for k:=1 to c do with p[k] do begin if (b<>1) then begin for i:=1 to m do if b<>1 then for j:=1 to m do if (bcount(i,j)=1) and chklet(i,j) then begin x:=i;y:=j;b:=1; for l:=1 to c do with p[l] do b:=bcount(x,y); break; end; end; end; end;writeln; for i:=1 to c do writeln(p[i].x,' ',p[i].y);readln; end.
Вроде работает. Можно было местами сделать оптимальней, выполняются лишние движения, но я решил, что при таких небольших размерностях и так сойдёт)
Автор: Merhaba 13.05.2011 10:23
Цитата(Unconnected @ 13.05.2011 0:57)
Слабонервным не читать
{$APPTYPE CONSOLE} end.
Вроде работает. Можно было местами сделать оптимальней, выполняются лишние движения, но я решил, что при таких небольших размерностях и так сойдёт)
Если Вам не сложно, объясните Пожалуйста алгоритм решения...
Автор: Unconnected 13.05.2011 11:26
Задаётся массив из 4-х элементов типа TPotate, в нем будет храниться инфа о каждой картофелине - координаты и количество бьющих её картошек. В начале этот массив заполняется, функция bcount находит, сколько клеток бьют клетку, координаты которой во входных параметрах ф-ии. Ну и главный цикл - проход по всем элементам массива, если какой-то эл-т бьёт не 1 клетка, а больше или меньше (а по условию нужна именно одна), то ищем такую клетку, которую бьёт одна другая клетка.. и переставляем. И обновляем информацию о том, какую клетку сколько бьют.
Автор: Merhaba 13.05.2011 11:46
Цитата(Unconnected @ 13.05.2011 8:26)
Задаётся массив из 4-х элементов типа TPotate, в нем будет храниться инфа о каждой картофелине - координаты и количество бьющих её картошек. В начале этот массив заполняется, функция bcount находит, сколько клеток бьют клетку, координаты которой во входных параметрах ф-ии. Ну и главный цикл - проход по всем элементам массива, если какой-то эл-т бьёт не 1 клетка, а больше или меньше (а по условию нужна именно одна), то ищем такую клетку, которую бьёт одна другая клетка.. и переставляем. И обновляем информацию о том, какую клетку сколько бьют.
Скажите Пожалуйста, а что обозначает " type TPotate=record" ? что происходит в "Function check:boolean;" ? что происходит в "function chklet(x2,y2:byte):boolean;" ?
Автор: Unconnected 13.05.2011 11:54
type TPotate=record x,y,b:byte; end;
var p:array[1..4] of TPotate;
record - запись, тут описывается новый тип по имени TPotate (наряду с другими типами, byte,integer..), представляющий собой запись. У этого типа есть 3 поля, будто 3 ящика в тумбочке-переменной. И к каждому этому ящику-полю можно отдельно обратиться, например p[1].x:=5; p[1].y:=6; p[1].b:=1;
Функция check проверяет, все ли картошки удовлетворяют условиям задачи, или ещё не все и нужно ещё раз пробежаться по массиву и что-то переставить. Хотя мне кажется, она здесь и не нужна, и все необходимые перестановки делаются за первый проход цикла while (в силу маленьких размерностей наверное). chklet проверяет, не занята ли клетка и можно ли туда поставить картошку. Анка и Петька ждали Чапаева и ели картошку. Вскоре они наелись и решили поиграть в «Чапаева» оставшимися четырьмя картофелинами.
Автор: Merhaba 13.05.2011 12:30
Цитата(Unconnected @ 13.05.2011 8:54)
type TPotate=record x,y,b:byte; end;
var p:array[1..4] of TPotate;
record - запись, тут описывается новый тип по имени TPotate (наряду с другими типами, byte,integer..), представляющий собой запись. У этого типа есть 3 поля, будто 3 ящика в тумбочке-переменной. И к каждому этому ящику-полю можно отдельно обратиться, например p[1].x:=5; p[1].y:=6; p[1].b:=1;
Функция check проверяет, все ли картошки удовлетворяют условиям задачи, или ещё не все и нужно ещё раз пробежаться по массиву и что-то переставить. Хотя мне кажется, она здесь и не нужна, и все необходимые перестановки делаются за первый проход цикла while (в силу маленьких размерностей наверное). chklet проверяет, не занята ли клетка и можно ли туда поставить картошку. Анка и Петька ждали Чапаева и ели картошку. Вскоре они наелись и решили поиграть в «Чапаева» оставшимися четырьмя картофелинами.
Спасибо Вам Большое!!! Лучще бы они Чапаева съели вместо картошки
Автор: Lapp 13.05.2011 13:24
Un, что-то у тебя не то..
Я добавил псевдографику. Красные номера - это переставленные картошки.
Ты переставил все четыре там, где можно было переставить только 2. Да и вообще, мне кажется, что тут в любом случае можно обойтись двумя.
Код Unconnected, дополненный выводом поля(Показать/Скрыть)
uses CRT; const c=4; m= 10;
type TPotate=record x,y,b:byte; end;
var p,p0: array[1..c] of TPotate; i,j,k,l: byte;
function bcount(x1,y1:byte):byte; var k,kx,ky:integer; begin result:=0;kx:=0;ky:=0; for k:=1 to c do with p[k] do begin if (x=x1) and (y<>y1) then begin case ky of 0:begin inc(result); if y1>y then ky:=1 else ky:=-1; end; 1:if y1<y then begin inc(result);ky:=2; end; -1:if y1>y then begin inc(result);ky:=2; end; end; end; if (x<>x1) and (y=y1) then begin case kx of 0:begin inc(result); if x1>x then kx:=1 else kx:=-1; end; 1:if x1<x then begin inc(result);kx:=2; end; -1:if x1>x then begin inc(result);kx:=2; end; end; end; end; end;
Function check:boolean; var k:byte; begin result:=true; for k:=1 to c do if p[k].b<>1 then begin result:=false; break; end; end;
function chklet(x2,y2:byte):boolean; var u:byte; begin result:=true; for u:=1 to c do if (p[u].x=x2) and (p[u].y=y2) then begin result:=false;break; end; end;
procedure Show; var i,j,k: integer; s: string; begin for i:=1 to m do begin for j:=1 to m do begin s:= ' +'; for k:=1 to c do with p[k] do if (x=i) and (y=j) then begin s:= ' '+Chr(48+k); if (p0[k].x<>x) or (p0[k].y<>y) then TextColor(LightRed) end; Write(s); TextColor(LightGray) end; WriteLn end end;
var f: text;
begin Assign(f,'merhaba.dat'); Reset(f); for i:=1 to c do with p[i] do begin b:=0; readln(f,x,y); end; close(f); p0:= p; Show; for i:=1 to c do with p[i] do b:=bcount(x,y); while not(check) do begin for k:=1 to c do with p[k] do begin if (b<>1) then begin for i:=1 to m do if b<>1 then for j:=1 to m do if (bcount(i,j)=1) and chklet(i,j) then begin x:=i;y:=j;b:=1; for l:=1 to c do with p[l] do b:=bcount(x,y); break; end; end; end; end; writeln; for i:=1 to c do writeln(p[i].x,' ',p[i].y); WriteLn; Show; readln; end.
Автор: sheka 13.05.2011 13:43
Объясните задание, пожалуйста.
Автор: Lapp 13.05.2011 14:53
Цитата(sheka @ 13.05.2011 10:43)
Объясните задание, пожалуйста.
На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.
Автор: Merhaba 13.05.2011 22:47
Цитата(Lapp @ 13.05.2011 11:53)
На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.
Объясните Пожалуйста, а что обозначает "Assign(f,'merhaba.dat');" ? Вывод полученной информации в файл?
На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.
Скажите Пожалуйста, а за что отвечают переменные var k,kx,ky:integer; ? и что обозначает p[k].b<>1 ?
Автор: Unconnected 14.05.2011 0:29
Это не очень правильное решение, как оказалось, не стоит его разбирать.. сейчас или завтра покажу рекурсивное, с перебором, сейчас пока не хочет работать)
Автор: Merhaba 14.05.2011 21:44
Цитата(Unconnected @ 13.05.2011 21:29)
Это не очень правильное решение, как оказалось, не стоит его разбирать.. сейчас или завтра покажу рекурсивное, с перебором, сейчас пока не хочет работать)
А что в вашей первоначальной программе работает неправильно?
Автор: Merhaba 18.05.2011 23:48
Цитата(Lapp @ 13.05.2011 11:53)
На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.
А можно сделать так? Картошек - 4. Из того, что одна бьет только одну, следует, что в каждом столбце и в каждой строке должно быть ровно 0, 1 или 2 картошки, также две непустые линии, в каждой из которых находится 2 картошки, не могут пересекаться в клетке с картошкой (иначе поледнюю будут бить 2 сразу). Значит нам нужно всего две пары расположить в разных линиях. Некоторые до этого могут уже быть итак разложены. Осталось только придумать способ. Можно сделать булевую матрицу и работать с ней. Можно сравнивать координаты.
Помогите Пожалуйста реализовать код
Автор: Unconnected 21.05.2011 18:17
Не знаю, нужно ли ещё, но вот (экзамены на носу, времени мало, да и не получалось поначалу..). Тут типа полный перебор, с отбором лучшего положения (страшноват, правда(очень)). Делаются лишние действия, но вроде работает.
{$APPTYPE CONSOLE}
const c=4;mp=20; type TBin=0..1; type TPotate=record x,y,b:byte; end;
var i,j,xx,yy,n:byte; z:integer; m:array[1..mp,1..mp] of TBin; p,br:array[1..c] of TPotate;
function bcount(p,k:byte):byte; var d,e:byte; begin result:=0;e:=0; for d:=1 to mp do if (m[p,d]=1) then if (d<>k) then begin inc(result);inc(e); end else begin if e>1 then begin dec(result,e-1);e:=0; end;e:=0; end; if e>1 then dec(result,e-1);e:=0; for d:=1 to mp do if (m[d,k]=1) then if (d<>p) then begin inc(result);inc(e); end else begin if e>1 then begin dec(result,e-1);e:=0; end;e:=0; end; if e>1 then dec(result,e-1); end;
function chOk:boolean; begin result:=true; for xx:=1 to mp do for yy:=1 to mp do if (m[xx,yy]=1) and (bcount(xx,yy)<>1) then begin result:=false;break; end; end;
Procedure PCount; var r,t,u:byte; begin u:=1; for r:=1 to mp do for t:=1 to mp do begin if m[r,t]=1 then with p[u] do begin x:=r;y:=t;b:=bcount(x,y);inc(u); end; end; end;
Procedure wou; begin for i:=1 to mp do begin for j:=1 to mp do write(m[i,j]); writeln; end;writeln;readln; end;
Procedure toex; begin fillchar(m,sizeof(m),0); for i:=1 to c do with p[i] do m[x,y]:=1; wou; end;
Procedure rec(h:byte); var d,f,t,l,xb,yb:byte; begin if (h=c+1) then begin l:=0;inc(z); for d:=1 to mp do for f:=1 to mp do if m[d,f]=1 then begin for t:=1 to c do if ((br[t].x=d) and (br[t].y=f)) then inc(l); end; l:=c-l; if chOk then begin if l<n then begin n:=l; pcount; if n=1 then toex; if z>mp*mp then if n=2 then toex; end; end; end else begin xb:=p[h].x;yb:=p[h].y; for d:=1 to mp do begin for f:=1 to mp do begin if (m[d,f]=0) or ((d=xb) and (f=yb)) then begin m[d,f]:=1; if not((d=xb) and (f=yb)) then m[xb,yb]:=0; rec(h+1); m[d,f]:=0; m[xb,yb]:=1; end; end; end; end; end;
begin fillchar(m,sizeof(m),0); for i:=1 to c do begin read(xx,yy);m[xx,yy]:=1; end;writeln; PCount; wou; n:=c;br:=p;z:=0; rec(1); toex; end.
Что интересно, процедура вывода матрицы изначально называлась wout; , что, наверное, является каким-то служебным словом.. факт в том, что readln; после последнего wout-а не останавливал прогу. Пришлось переименовать) И да, мне кажется в таких задачах лучше перебор (хоть и с оптимизациями возможными, отсечениями), чем думать что-то типа "таак, оптимальная ситуация это когда в одной грядке 2 картошки, и переставим ещё одну, тогда..."..., короче, пытаться сделать однопроходно. Ибо задача может трансформироваться в пересадку 5 картошек, и тогда думать придется заново)
Автор: Merhaba 21.05.2011 23:47
Цитата(Unconnected @ 21.05.2011 15:17)
Не знаю, нужно ли ещё, но вот (экзамены на носу, времени мало, да и не получалось поначалу..). Тут типа полный перебор, с отбором лучшего положения (страшноват, правда(очень)). Делаются лишние действия, но вроде работает.
Спасибо Вам Большое за помощь!!! попробовал закинуть на контест, выдало ошибку: ТаймЛимит на 1-ом тесте. Как можно оптимизировать код, чтобы уложится в 0,5 секунды?