рекурсия- разбиение и сборка квадрата Опции

[Lapp]

функция для определения пересечений есть, остаётся перебирать?)

Перебирать что? Входных данных пока еще нет..
Можно, конечно, полагать, что это забота не наша, а проверяющего задание, но как тогда отлаживаться? И, в любом случае, как ни крути, нужно все же договориться о формате ввода..

Я все же предлагаю подумать о том, как подготовить (ну и в какой форме сохранить) входной набор прямоугольников.

И еще одна просьба: не гоните, дайте автору темы хотя бы отреагировать и задать вопросы..

[Lapp]

Кать, если тебе не актуально уже, ты скажи.
А если такими темпами, то и к следующему пнд не будет готово.
С чем загвоздка? Если что-то неясно - спрашивай.

[Екатерина7]

да,Lapp, с математикой все понятно.. да и с кусочком программы вроде бы тоже..)

Добавлено через 2 мин.
извиняюсь,у меня пару дней с инетом проблемы были,не могла ответить..(( все нормально..вроде бы понятно.. все остается так же актуальным..

Добавлено через 9 мин.
входные данные- параметры прямоугольников,как говорил Unconnected.так?

[Lapp]

входные данные- параметры прямоугольников,как говорил Unconnected.так?

Да, так. Вопрос, как.

По условию, у нас должен быть на входе набор прямоугольников, из которого заведомо можно построить квадрат, поскольку "Лист бумаги в клетку квадратной формы размера NxN произвольно разрезан на прямоугольные части, каждая из которых имеет целое число клеток". Если такой набор приложен к условию, то наша задача облегчается (Катя, ты спроси преподавателя - может, у него есть такой). Если нет - то надо его сначала сделать, то есть нам нужно имплементить способ разрезания квадрата. Либо..

У набора, из которого можно построить квадрат есть одно обязательное свойство: сумма всех клеток всех его прямоугольников равна количеству клеток в квадрате, то есть N*N. Но это не есть достаточное условие.

Предположим, мы создали набор прямоугольников (со стороной не больше, чем N), и сумма их площадей (клеток) равна N*N (это сделать нетрудно - легче, чем разрезать). Далее, наша будущая программа попытается собрать из них квадрат. Если у нее это получается, то она выдает ответ: "квадрат собрать можно" (и, может быть, порядок сборки). Если же все ее попытки заканчиваются ничем. то она говорит: "квадрат собрать невозможно".

То, что я предложил выше - это видоизменение условия. Я не знаю, насколько такие зменения допустимы. Поэтому я предлагаю: Катя, спроси преподавателя:
1. существует ли набор входных данных для проверки? Если да, то где его взять и в каком он формате.
2. если нет, то возможно ли вместо повторной сборки просто брать случайный набор (с суммарной площадью N*N) и говорить, можно ли из него собрать квадрат (с выдачей порядка сборки в случае удачи).

Либо спроси, либо сама скажи, что делать, потому что от этого зависит программа. Ok?

[Екатерина7]

набора входных данных нет.. думаю, что можно брать вместо повторной сборки просто случайный набор..

[Lapp]

думаю, что можно брать вместо повторной сборки просто случайный набор..

Хорошо. Ну, давай тогда делать случайный набор. Создать и записать в файл square.dat в таком формате: длина и ширина на одной строке; строк стролько, сколько прямоугольников.
Сможешь сделать?

[Екатерина7]

если честно, несовсем:( у меня с этим возникли трудности.. вооюще затрудняюсь начать..

[Lapp]

Ну, начать я тебе помогу

var
  s,q: integer;
  t: tRectangle;
  f: text;

begin
  s:=0;  {сумма всех клеток}
  m:=0;  {количество прямоугольников}
  with t do repeat
...

Можешь продолжить?

[Екатерина7]

наверно нет.. затрудняюсь.. в написанном могу разобраться.. а так..

[Unconnected]

Екатерина7, ты какой курс, если не секрет?

Просто, видимо, у тебя практики мало было. Очень мало. А тут раз - и рекурсия с квадратами...

[Екатерина7]

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

[Екатерина7]

[klem4]

Перебор с рекурсией, код неважнецкий, но работает

{$mode TP}
{$r-}
uses crt;

type

  TBlock = object
    constructor _new(const r, c: integer; const s: char);
    procedure shift;
    row, col: integer;
    sign: char;
  end;

  TRow = array [1..1] of char;
  PTRow = ^TRow;

  TField = array [1..1] of PTRow;
  PTField = ^TField;

  TBlockField = object
    constructor _new( const n: integer );
    destructor  _free;
    procedure   _print;
    procedure   _assign( const b: TBlock; const row, col: integer; const unassign: boolean);
    function can_assign( const b: TBlock; const row, col: integer ): boolean;

    function fill(f: array of TBlock; fi: integer): boolean;

    field: PTField;
    sz: integer;

    done: boolean;
  end;

constructor TBlock._new(const r, c: integer; const s: char);
begin
    row := r; col := c; sign := s;
end;

procedure TBlock.shift;
var
    t: integer;
begin
    t := row; row := col; col := t;
end;

constructor TBlockField._new( const n: integer );
var
    i, j: integer;
begin
    GetMem( field, n * sizeof( PTRow ));
    for i := 1 to n  do
        GetMem( field^[i], n * sizeof(integer));

    for i := 1 to n do
    for j := 1 to n do
    field^[i]^[j] := '0';

    sz := n;
    done := false;
end;

destructor  TBlockField._free;
var
    i, j: integer;
begin
    for i := 1 to sz do FreeMem( field^[i], sz * sizeof(integer));
    FreeMem(field, sz * sizeof(PTRow));
end;

procedure   TBlockField._print;
const colors: array ['a'..'g'] of byte = (red,blue,green,lightred,yellow,lightblue,lightgreen);
var
    i, j: integer;
begin
    for i := 1 to sz do begin
        for j := 1 to sz do begin
            if (field^[i]^[j] = '0') then TextColor(white) else TextColor(colors[field^[i]^[j]]);
            write(field^[i]^[j]:2);
        end;
        writeln;
    end;
    writeln;
end;

procedure TBlockField._assign( const b: TBlock; const row, col: integer;
 const unassign: boolean);
var
    i, j: integer;
    s: char;
begin
    if ( unassign ) then s := '0' else s := b.sign;
    for i := row to row + b.row - 1 do
        for j := col to col + b.col - 1 do
            field^[i]^[j] := s;
end;

function TBlockField.can_assign( const b: TBlock;
 const row, col: integer ): boolean;
var
    r, c: integer;
    ok: boolean;
begin
  if ( row + b.row  - 1 > sz ) or ( col + b.col - 1 > sz ) then
    can_assign := false
  else begin
    ok := true;
    r := row;
    while (( r < row + b.row ) and ( ok )) do begin
        c := col;
        while (( c < col + b.col ) and ( ok )) do begin
            ok := field^[r]^[c] = '0';
            inc©;
        end;
        inc®;
    end;
    can_assign := ok;
  end;
end;


function TBlockField.fill(f: array of TBlock; fi: integer): boolean;
var
    i, r, c, s: integer;
begin
  if ( fi = length(f) ) then done := true;

  if done then fill := true;

  for r := 1 to sz - f[fi].row + 1 do
   for c := 1 to sz - f[fi].col  + 1 do
    for s := 0 to 1 do begin
     if ( s = 1 ) then f[fi].shift;
     if not(done) and ( field^[r]^[c] = '0' ) and ( can_assign(f[fi], r, c ) ) then begin
         _assign(f[fi], r, c, false);
         fill := fill(f, fi + 1);
         if not done then _assign(f[fi], r, c, true);

     end;
    end;
  fill := done;
end;

var
  bf: TBlockField;
  b: TBlock;
  f: array [1..6] of TBlock;

begin
    clrscr;

    f[1]._new(2,1,'a');
    f[2]._new(2,2,'b');
    f[3]._new(1,1,'c');
    f[4]._new(1,1,'d');
    f[5]._new(2,1,'e');
    f[6]._new(2,3,'f');

    bf._new( 4 );
    writeln(bf.fill(f, 0));
    bf._print;

    bf._free;
    readln;
end.

[Lapp]

Перебор с рекурсией, код неважнецкий, но работает

Круто, Клёма! А как ты задаешь начальные данные?
Я седни попожжее выложу свой тож тогда.

[klem4]

Код

f[1]._new(2,1,'a');
f[2]._new(2,2,'b');
...

это массив "кусочков", параметры - длина, ширина и буква.

Код

bf._new( 4 ); // собственно объект - поле, параметр - размер (4х4)
writeln(bf.fill(f, 0)); // заполнение поля, вернет true если можно заполнить из кусочков, хранящихся в f

[Unconnected]

А теперь возникает вопрос: с какой вероятностью Екатерине7 поверят, что она это писала сама?

[Екатерина7]

поверят, я постараюсь разобраться))

Добавлено через 3 мин.
проверим потом на практике с какой вероятностью))

[Lapp]

проверим потом на практике с какой вероятностью))

Если бы я принимал, она бы стремилась к нулю )). И все же желаю успехов (особенно в "разобраться").

Выкладываю свой код тоже. Я хотел выделить подготовку начальных данных в отдельную прогу и писать их в файл, но не сделал..

uses
  CRT;
const
  n=8;   {размер квадрата}

type
  tRectangle=record
    a,b: integer
  end;
  tLocation=record
    x,y: integer
  end;

const
  r0: tRectangle=(a:1; b:1);
  l0: tLocation=(x: 0; y: 0);

function Overlap(r1: tRectangle; l1: tLocation; r2: tRectangle; l2: tLocation): boolean;
begin
  Overlap:=
    (Abs(l2.x*2+r2.a-l1.x*2-r1.a) < r1.a+r2.a) and
    (Abs(l2.y*2+r2.b-l1.y*2-r1.b) < r1.b+r2.b)
end;

var
  r: array[1..n*n+10]of tRectangle;
  l: array[1..n*n+10]of tLocation;
  s,i,m,k,done: integer;
  t: tRectangle;
  u: tLocation;
  Clear: boolean;

procedure Show;   {печать квадрата}
var
  i,j,k: integer;
  c: char;
begin
  for j:=1 to n do begin
    for i:=1 to n do begin
      c:='.';
      for k:=1 to m do with r[k] do with l[k] do
        if (x>0)and(x<=i)and(i<x+a)and(y<=j)and(j<y+b) then c:=Chr(k+64);
      Write©
    end;
    WriteLn
  end;
  WriteLn
end;

procedure JustSet;    {подготовка входных данных}
var
  s,q,k: integer;
  t: tRectangle;
begin
  s:=0;
  m:=0;
  k:=2;
  with t do repeat
    a:=Random(k)+1;
    b:=Random(k)+1;
    q:=s+a*b;
    if q<=n*n then begin
      Inc(m);
      r[m]:=t;
      l[m]:=u;
      s:=q
    end
  until s=n*n
end;

procedure Put(x,y: integer);
var
  i,j: integer;
  li: tLocation;
  NoOne: boolean;
  c: char;
begin
  if y<=n then begin
    li.x:=x;
    li.y:=y;
    NoOne:=true;
    for i:=1 to m do with r[i] do if l[i].x=0 then begin
      if (x+a<n+2)and(y+b<n+2) then begin
        Clear:=true;
        for j:=1 to m do if l[j].x>0 then Clear:=Clear and not Overlap(r[i],li,r[j],l[j]);
        if Clear then begin
          Inc(k);
          l[i]:=li;
          if k=m then begin
            Inc(done);
            WriteLn('Done   ',done);
            Show;
            c:=ReadKey;
            if c=#27 then Halt
          end
          else Put(x mod n+1,y+x div n);
          l[i]:=l0;
          Dec(k);
          NoOne:=false
        end
      end;
      if a<>b then begin
        j:=a;
        a:=b;
        b:=j;
        if (x+a<n+2)and(y+b<n+2) then begin
          Clear:=true;
          for j:=1 to m do if l[j].x>0 then Clear:=Clear and not Overlap(r[i],li,r[j],l[j]);
          if Clear then begin
            Inc(k);
            l[i]:=li;
            if k<>m then Put(x mod n+1,y+x div n);
            l[i]:=l0;
            Dec(k);
            NoOne:=false
          end
        end;
        j:=a;
        a:=b;
        b:=j;
      end
    end;
    if NoOne then Put(x mod n+1,y+x div n)
  end
end;

begin
  JustSet;
  WriteLn('m=',m);
  s:=0;
  for i:=1 to m do with r[i] do begin
    s:=s+a*b;
    WriteLn('a=',a:2,'     b=',b:2,'     ab=',a*b:4,'     s=',s:4);
  end;
  done:=0;
  Put(1,1);
  WriteLn('Completed')
end.

Катя, ты спрашивай больше. Не стесняйся

Добавлено через 4 мин.
klem4, зачем отключил $R ?

[volvo]

klem4, зачем отключил $R ?

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

[klem4]

К сожалению не знаю как еще дин. массивы в таком виде с fpc подружить