Координаты картофелин Опции

[Merhaba]

Добрый Вечер!!!
Помогите Пожалуйста решить задачу, очень надо!!!
Ограничение времени: 0.5 секунды
Ограничение памяти: 64 МБ

Анка и Петька ждали Чапаева и ели картошку. Вскоре они наелись и решили поиграть в «Чапаева» оставшимися четырьмя картофелинами.
Петька достал доску размером 20 × 20 клеток, положил на неё картофелины и сказал, что по правилам никакие две картофелины не могут находиться в одной клетке, а одной картофелиной можно сбить другую только в том случае, если они расположены на одной горизонтали или вертикали и между ними нет других картофелин.
Анка предложила взять некоторые картофелины и поставить их на другие свободные клетки так, чтобы каждой картофелиной можно было сбить ровно одну другую. Помогите Петьке переставить как можно меньше картофелин, чтобы выполнить её просьбу.
Исходные данные
В четырёх строках записаны координаты картофелин xi, yi — целые числа в пределах от 1 до 20. Никакие две картофелины не расположены в одной клетке.
Результат
Выведите новые координаты картофелин. Картофелины следует описывать в том же порядке, в котором они заданы на входе. Если возможных ответов несколько, выведите любой.

Пример:
1 1
2 2
4 4
4 3
Результат:
1 2
2 2
4 4
4 3

[Unconnected]

Слабонервным не читать

{$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.

Вроде работает. Можно было местами сделать оптимальней, выполняются лишние движения, но я решил, что при таких небольших размерностях и так сойдёт)

Сообщение отредактировано: Unconnected - 13.05.2011 0:04

[Merhaba]

Слабонервным не читать

{$APPTYPE CONSOLE}
end.

Вроде работает. Можно было местами сделать оптимальней, выполняются лишние движения, но я решил, что при таких небольших размерностях и так сойдёт)

Если Вам не сложно, объясните Пожалуйста алгоритм решения...

[Unconnected]

Задаётся массив из 4-х элементов типа TPotate, в нем будет храниться инфа о каждой картофелине - координаты и количество бьющих её картошек. В начале этот массив заполняется, функция bcount находит, сколько клеток бьют клетку, координаты которой во входных параметрах ф-ии. Ну и главный цикл - проход по всем элементам массива, если какой-то эл-т бьёт не 1 клетка, а больше или меньше (а по условию нужна именно одна), то ищем такую клетку, которую бьёт одна другая клетка.. и переставляем. И обновляем информацию о том, какую клетку сколько бьют.

Сообщение отредактировано: Unconnected - 13.05.2011 7:28

[Merhaba]

Задаётся массив из 4-х элементов типа TPotate, в нем будет храниться инфа о каждой картофелине - координаты и количество бьющих её картошек. В начале этот массив заполняется, функция bcount находит, сколько клеток бьют клетку, координаты которой во входных параметрах ф-ии. Ну и главный цикл - проход по всем элементам массива, если какой-то эл-т бьёт не 1 клетка, а больше или меньше (а по условию нужна именно одна), то ищем такую клетку, которую бьёт одна другая клетка.. и переставляем. И обновляем информацию о том, какую клетку сколько бьют.

Скажите Пожалуйста, а что обозначает " type TPotate=record" ?
что происходит в "Function check:boolean;" ?
что происходит в "function chklet(x2,y2:byte):boolean;" ?

[Unconnected]

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 проверяет, не занята ли клетка и можно ли туда поставить картошку.

Анка и Петька ждали Чапаева и ели картошку. Вскоре они наелись и решили поиграть в «Чапаева» оставшимися четырьмя картофелинами.

Сообщение отредактировано: Unconnected - 13.05.2011 7:55

[Merhaba]

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]

Un, что-то у тебя не то..

Я добавил псевдографику. Красные номера - это переставленные картошки.

 1 2 3 4 + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +


2 3
2 1
1 4
1 10

 + + + 3 + + + + + 4
 2 + 1 + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +
 + + + + + + + + + +

Ты переставил все четыре там, где можно было переставить только 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]

Объясните задание, пожалуйста.

[Lapp]

Объясните задание, пожалуйста.

На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.

[Merhaba]

На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.

Объясните Пожалуйста, а что обозначает "Assign(f,'merhaba.dat');" ?
Вывод полученной информации в файл?

[sheka]

http://www.google.com.ua/search?hl=ru&q=pa...256l2414l2.10.4

[Merhaba]

На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.

Скажите Пожалуйста, а за что отвечают переменные var k,kx,ky:integer; ?
и что обозначает p[k].b<>1 ?

[Unconnected]

Это не очень правильное решение, как оказалось, не стоит его разбирать.. сейчас или завтра покажу рекурсивное, с перебором, сейчас пока не хочет работать)

[Merhaba]

Это не очень правильное решение, как оказалось, не стоит его разбирать.. сейчас или завтра покажу рекурсивное, с перебором, сейчас пока не хочет работать)

А что в вашей первоначальной программе работает неправильно?

[Merhaba]

На доске 4 ладьи. Переместить минимальное количество так, чтобы в результате каждая ладья била ровно одну другую.

А можно сделать так?
Картошек - 4. Из того, что одна бьет только одну, следует, что в каждом столбце и в каждой строке должно быть ровно 0, 1 или 2 картошки, также две непустые линии, в каждой из которых находится 2 картошки, не могут пересекаться в клетке с картошкой (иначе поледнюю будут бить 2 сразу). Значит нам нужно всего две пары расположить в разных линиях. Некоторые до этого могут уже быть итак разложены. Осталось только придумать способ. Можно сделать булевую матрицу и работать с ней. Можно сравнивать координаты.

Помогите Пожалуйста реализовать код

[Unconnected]

Не знаю, нужно ли ещё, но вот (экзамены на носу, времени мало, да и не получалось поначалу..).
Тут типа полный перебор, с отбором лучшего положения (страшноват, правда(очень)). Делаются лишние действия, но вроде работает.

{$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 картошек, и тогда думать придется заново)

Сообщение отредактировано: Unconnected - 21.05.2011 15:50

[Merhaba]

Не знаю, нужно ли ещё, но вот (экзамены на носу, времени мало, да и не получалось поначалу..).
Тут типа полный перебор, с отбором лучшего положения (страшноват, правда(очень)). Делаются лишние действия, но вроде работает.

Спасибо Вам Большое за помощь!!! попробовал закинуть на контест, выдало ошибку: ТаймЛимит на 1-ом тесте. Как можно оптимизировать код, чтобы уложится в 0,5 секунды?

Сообщение отредактировано: Merhaba - 21.05.2011 19:49