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

[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