помогите, пожалуйста, разобраться с задачей
Лист бумаги в клетку квадратной формы размера NxN произвольно разрезан на прямоугольные части, каждая из которых имеет целое число клеток. Полученные прямоугольные куски перемешаны. Требуется из заданных прямоугольников снова составить квадрат. Квадрат не обязательно должен быть составлен из прямоугольников в том же порядке, в каком он разрезан. При сборке прямоугольники можно поворачивать.
(число N не задано, можно брать любое)
хорошо, допустим N=10
А как входные данные выглядят?
может входными данными могут быть массивы этих прямоугольников,состоящие из клеточек?
type, где lx - размер по x, а ly - размер по y, а x,y - положение угла с минимальными координатами. У нас координаты будут идти так:
tRectangle=record
lx,ly: integer;
end;
tLocation=record
x,y: integer
end;
var
r1,r2: tRectangle;
l1,l2: tLocation;
function Overlap(r1,l1,r2,l2): boolean;
может просто сравнивать положения этих прямоугольников, их воординаты? если совпадут-то пересекаются.. может там цикл нужен?
Ага, надо сравнивать, ну он видимо спрашивал про конкретные соотношения, что с чем и как сравнивать.
да я в приниципе поняла про что.. думаю конкретно как..
Добавлено через 11 мин.
походу нужно какое-то условие..
Добавлено через 17 мин.
сравнивать координаты расположения
Ну да, координаты нужно сравнивать, но нельзя забывать и про размеры прямоугольников..
Написал функцию, вроде правильно:
type
tRectangle=record
lx,ly:integer;
end;
tLocation=record
x,y:integer;
end;
function overlapp(r1,r2:tRectangle; l1,l2:tLocation):boolean;
begin
overlapp:=false; //заранее присваиваем функции значение false, т.е. что прям-ки не пересекаются. Оно может
//измениться в процессе выполнения. Не изменится - значит, не пересекаются.
if ((l1.x=l2.x) and (l1.y=l2.y)) then overlapp:=true; //самая первая проверка. Если координаты совпадают,
//то прям-ки пересекаются
if (l1.x>=l2.x) then if (l2.x+r2.lx)>=l1.x then overlapp:=true;
if (l2.x>=l1.x) then if (l1.x+r1.lx)>=l2.x then overlapp:=true; //далее. Если сумма координаты X одного
//прям-ка и его длины больше или равна координате X второго прям-ка, то они пересекаются.
if (l1.y>=l2.y) then if (l2.y+r2.ly)>=l1.y then overlapp:=true;
if (l2.y>=l1.y) then if (l1.y+r1.ly)>=l2.y then overlapp:=true; //и ещё пара условий. Если сумма
//координаты Y одного прям-ка и его ширины больше или равна координате Y второго прям-ка, то
//они пересекаются.
end;
volvo,
type
tRectangle=record
lx,ly:integer;
end;
tLocation=record
x,y:integer;
end;
function overlapp(r1,r2:tRectangle; l1,l2:tLocation):boolean;
begin
overlapp:=false;
if ((l1.x=l2.x) and (l1.y=l2.y)) then overlapp:=true;
if (l1.x>l2.x) then if (l2.x+r2.lx)>l1.x then
begin
if (l1.y>l2.y) then if (l2.y+r2.ly)>l1.y then overlapp:=true;
if (l1.y<l2.y) then if (l1.y+r1.ly)>l2.y then overlapp:=true;
end;
if (l2.x>l1.x) then if (l1.x+r1.lx)>l2.x then
begin
if (l2.y>l1.y) then if (l1.y+r1.ly)>l2.y then overlapp:=true;
if (l2.y<l1.y) then if (l2.y+r2.ly)>l1.y then overlapp:=true;
end;
end;
const, и почему у меня ощущение, что должно быть False, а выдается True?
r1: trectangle = (lx:10; ly:5);
r2: trectangle = (lx:10; ly:5);
l1: tlocation = (x:0; y:0);
l2: tlocation = (x:11; y:5);
begin
writeln(overlapp(r1, r2, l1, l2));
end.
volvo, у нас квадрат ограничивается 10
Я написал такой код, принцип у него другой, нежели у первого, но вот почему-то в конце массивов не координаты а чушь какая-то вперемешку с ними, и на введённых данных тоже True выдаёт:
type
tRectangle=record
lx,ly:integer;
end;
tLocation=record
x,y:integer;
end;
const n=10;
r1:trectangle=(lx:10;ly:5);
r2:trectangle=(lx:10;ly:5);
l1:TLocation=(x:0;y:0);
l2:TLocation=(x:11;y:5);
function overlapp(r1,r2:tRectangle; l1,l2:tLocation):boolean;
var rec1,rec2:array[0..500] of tLocation;
i,j,k,l:byte;
begin
k:=0;
for i:=l1.x to l1.x+r1.lx do
for j:=l1.y to l1.y+r1.ly do begin
rec1[k].x:=i;
rec1[k].y:=j;
inc(k);
end;
k:=1;
for i:=l2.x to l2.x+r2.lx do
for j:=l2.y to l2.y+r2.ly do begin
rec2[k].x:=i;
rec2[k].y:=j;
inc(k);
end;
overlapp:=false;
for i:=0 to k do
for j:=0 to k do
begin
if (rec1[i].x=rec2[i].x) and (rec1[i].y=rec2[i].y) then begin
overlapp:=true;
break;
end;
end;
end;
begin
writeln(overlapp(r1,r2,l1,l2));
readln;
end.
-что-то я не пойму, а какой тут принцип?
type
tRectangle=record
lx,ly:integer;
end;
tLocation=record
x,y:integer;
end;
const n=10;
r11:trectangle=(lx:10;ly:5);
r22:trectangle=(lx:10;ly:5);
l11:TLocation=(x:0;y:0);
l22:TLocation=(x:9;y:5);
function overlapp(r1,r2:tRectangle; l1,l2:tLocation):boolean;
var rec1,rec2:array[0..n*n] of tLocation;
i,j,k,l:integer;
begin
k:=0;
fillchar(rec1,n*n*sizeof(tLocation),0);
fillchar(rec2,n*n*sizeof(tLocation),0);
for i:=l1.x to l1.x+r1.lx do
for j:=l1.y to l1.y+r1.ly do begin
rec1[k].x:=i;
rec1[k].y:=j;
inc(k);
end;
l:=0;
for i:=l2.x to l2.x+r2.lx do
for j:=l2.y to l2.y+r2.ly do begin
rec2[l].x:=i;
rec2[l].y:=j;
inc(l);
end;
overlapp:=false;
for i:=1 to k-1 do
for j:=1 to l-1 do
begin
if (rec1[i].x=rec2[j].x) and (rec1[i].y=rec2[j].y) then begin
overlapp:=true;
break;
end;
end;
end;
Unconnected, что-то сложновато .
Hint: условие того, что прямоугольники не пересекаются: (r1.Right < r2.Left) or (r1.Left > r2.Right) or (r1.Top > r2.Bottom) or (r1.Bottom < r2.Top).
Не знаю, как с точки зрения Екатерина7, но лично мне нравится, что обсуждение получилось оживленным )). Также спасибо volvo за осторожные коррекции направлений.
Unconnected пошел хитрым путем, решив, что "против лома нет приема". Если математические соотношения становятся слишком сложными - будем решать тупо в лоб: массивы координат, смотрим наличие в них одинаковых. Способ чрезвычайно ресурсоемкий и совершенно непригодный для случая непрерывных координат (что, впрочем, тут не нужно).
Archon говорит в принципе верные вещи, но они мало отличаются от того, что завело в тупик Неприсоединенного. Слишком много проверок.
Катя, дальше следи внимательно, и если что-то неясно - говори.
Мы немного отойдем от условия и будем пока рассматривать не прямоугольники, а , скажем, круги на плоскости. Поначалу кажется, что ситуация только усложнилась - круг со многих точек зрения сложнее прямоугольника. Но на самом деле, после первого взгляда на чертеж (даже в уме)) становится ясно, что нужно сравнивать не координаты точек на окружности, а координаты центров. А именно: если расстояние между центрами больше, чем сумма радиусов этих кругов, то круги не пересекаются. Если меньше (либо равно) - пересекаются (касаются). Вот и все. Это понятно?
Теперь обсудим другую ситуацию, тоже не совсем прямо вытекающую из условий задачи; а именно - отрезки на прямой. По сути, отрезок на прямой - это есть КРУГ в одномерном пространстве. И хотя обычно, говоря об отрезке, мало кто специально указывает положение его центра (как в случае окружности), он у него все же есть )). Давайте будем описывать отрезки не как обычно (началом и концом), а их центрами и радиусами (радиус отрезка равен половине его длины). И сразу же становится понятно, что условие пересечения двух отрезков на прямой записывается точно так же, как и кругов на плоскости. И не надо проверять несколько случаев.. ))
Дальше. Фактически, условие пересечения двух прямоугольников распадается на два условия по координатам, причем нужно брать их логическое пересечение (условие выполнено только когда оба условия по координатам отдельно выполнены) - это легко понять, нарисовав несколько случаев на бумажке(или снова в уме)).
Таким образом, условие пересечения двух прямоугольников выглядит так (см. рисунок) - красное dx должно быть меньше суммы двух отрезков, отмесенных желтым:
|C2 - C1| <= L1/2 + L2/2
Это соотношение нужно проверить по X и по Y, и если в обоих случаях условия выполняются - значит, прямоугольники пересекаются. Прежде чем выписать окончательное выражение, я замечу еще вот, что. В выражении присутствует деление на два, которое добавляет ложку дегтя в нашу бочку с медом, так как требует введения переменных действительного типа со всеми вытекающими (сравнение действительных переменных протекает сложнее..) Поэтому мы заменим эту формулу эквивалентной, умноженной на два.
Итак, в результате имеем:
( 2*|Cx2-Cx1| <= Lx1 + Lx2 ) /\ ( 2*|Cy2-Cy1| <= Ly1 + Ly2 )
Катя, ты поняла математику? пожалуйста, ответь.
Ну вот, теперь можно переходить к программированию..
Я немного изменил названия переменных - извиняюсь за это, просто я тогда поспешил. Для однообразия лучше иметь вместо lx и ly однобуквенные идентификаторы a и b для длины и ширины. Вллюще, это не в полном смысле длина и ширина, а просто размер по x (это a) и по y (это b).
В итоге пресловутая функция будет выглядеть примерно так:
type
tRectangle=record
a,b: integer
end;
tLocation=record
x,y: integer
end;
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;
Хотя, по словам Lapp'а,
Кать, если тебе не актуально уже, ты скажи.
А если такими темпами, то и к следующему пнд не будет готово.
С чем загвоздка? Если что-то неясно - спрашивай.
да,Lapp, с математикой все понятно.. да и с кусочком программы вроде бы тоже..)
Добавлено через 2 мин.
извиняюсь,у меня пару дней с инетом проблемы были,не могла ответить..(( все нормально..вроде бы понятно.. все остается так же актуальным..
Добавлено через 9 мин.
входные данные- параметры прямоугольников,как говорил Unconnected.так?
набора входных данных нет.. думаю, что можно брать вместо повторной сборки просто случайный набор..
если честно, несовсем:( у меня с этим возникли трудности.. вооюще затрудняюсь начать..
Ну, начать я тебе помогу
var
s,q: integer;
t: tRectangle;
f: text;
begin
s:=0; {сумма всех клеток}
m:=0; {количество прямоугольников}
with t do repeat
...
наверно нет.. затрудняюсь.. в написанном могу разобраться.. а так..
Екатерина7, ты какой курс, если не секрет?
Просто, видимо, у тебя практики мало было. Очень мало. А тут раз - и рекурсия с квадратами...
не секрет- 4-й.. да.. нас плохо научили программир.. первые курсы особенно.. вот так все и пошло.. сейчас более менее с остальным стараюсь разбираться, а вот эту задачу не могу сделать..(
Перебор с рекурсией, код неважнецкий, но работает
{$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.
А теперь возникает вопрос: с какой вероятностью Екатерине7 поверят, что она это писала сама?
поверят, я постараюсь разобраться))
Добавлено через 3 мин.
проверим потом на практике с какой вероятностью))
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.
К сожалению не знаю как еще дин. массивы в таком виде с fpc подружить
спасибо, Lapp)
Добавлено через 5 мин.
я в принципе с тобой согласна,я программир плохо знаю..
Lapp, что-то я вообще не могу понять этой программы... точнее ее выполенение.. что-то странно.. какие-то буквы, цифры.. можешь объяснить, пожалуйста.
Екатерина7, какой у тебя уровень программирования в целом? Ты знаешь о типах данных, описании пользовательских типов, функциях, процедурах, операторах в конце концов и т.п.? Просто "буквы, цифры" заставляют задуматься, не рано ли тебе квадраты собирать..
извини, но хватит говорить про мой уровень программир.. не могу понять результата выполнения.вот и просила объяснить.. как и что получается.
ммм. да, это поняла.. такой вопрос: то, что выводится в результатах, Done:... квадрат с буквами, это и есть наш лист бумаги , разбитый на прямоугольники? и несовсем пойму,что за колонки букв в начале с цифрами (это тоже в результатах) , это набор , из которого строятся прямоугольники ниже?
а почему Done выводится одно и тоже бесконечное количество раз, программа зацикливается кажется.. как сделать выход из рекурсии? или не нужно?
Добавлено через 5 мин.
большие заглавные буквы латинские, это ячейки , в смысле эти прямоугольники , которые мы подбираем. так?
Добавлено через 1 мин.
еще вопрос) а почему вначале параметров а,b,s,там 14 ?там же вроде как квадрат 8*8..
результаты выполнения:
a=2 b=2 ab=4 s=32
a=1 b=2 ab=2 s=34
a=2 b=1 ab=2 s=36
a=1 b=1 ab=1 s=37
a=2 b=1 ab=2 s=39
a=2 b=1 ab=2 s=41
a=2 b=2 ab=4 s=45
a=2 b=2 ab=4 s=49
a=2 b=1 ab=2 s=51
a=2 b=2 ab=4 s=55
a=2 b=2 ab=4 s=59
a=2 b=1 ab=2 s=61
a=2 b=1 ab=2 s=63
a=1 b=1 ab=1 s=64
Done 1
ABBCDE FG
HI I I J J MM
KKL LN O OP
KKQQR R SU
T TVVV V V_
WWXXY Y Z_
[ [ [ [ [ [ \_
[ [ ] ] ^ ^^_
нет, не в ручную.. все печатала.. хорошо, проверю.
а что делает function Overlap?
я задала n=6, все получается нормально, без вот этого
[ [ [ [ [ [ \_
[ [ ] ] ^ ^^_
так там не должно быть этих скобок? или они должны быть красным? что-то у меня ничего не выделяется.. ничего не пойму:(
Добавлено через 1 мин.
я проверяла.. все так же , как я и написала.. результаты такие же..
ааааа.. эти скобочки не должны быть углом?
да, если n брать =8, добавляются скобочки и они углом, как и выше нарисовано
У меня при N=8 первая комбинация такая получается (скопировал из cmd):
все, получается. да
Добавлено через 7 мин.
идея понятна.. несовсем пойму расположение этих бкув и символов. точнее почему кое-где по одной букве.. она считается за прямоугольник?
потому что сначала не получалось..(
Добавлено через 6 мин.
а можно процедуру Put пошагово объяснить, конкретнее,если можно..
и что такое Inc(k);
Добавлено через 1 мин.
tRectangle, tLocation это какой-то тип?
а для чего вот это?
const
r0: tRectangle=(a:1; b:1);
l0: tLocation=(x: 0; y: 0);
что такое r0 и l0?
Добавлено через 4 мин.
еще хотела спросить, а что делает эта функция
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;
Добавлено через 16 мин.
function Overlap- эта функция проверяет пересекаются ли прямоугольники?
заметила. а что такое NoOne?
Добавлено через 9 мин.
например, вот тут
Ну, насколько я понял, NoOne - булевая переменная, обеспечивающая условие выхода из рекурсии. Т.е. если рекурсивная функция находит очередной вариант, то рекурсивно вызывается эта же функция с изменёнными параметрами, иначе рекурсия кончается.
Условие выхода из рекурсии:
if NoOne then Put(x mod n+1,y+x div n)
я так поняла, что function Overlap(r1: tRectangle; l1: tLocation; r2: tRectangle; l2: tLocation): boolean; -функция, которая выдает True, если прямоугольники пересекаются и False,если нет. так? только если честно, этого я в программе не вижу, в смысле где именно это описывается..
Добавлено через 1 мин.
ааа.. спасибо большое!
Добавлено через 5 мин.
можешь еще объяснить хотя бы в кратце, что делает procedure JustSet; {подготовка входных данных}
вот тут
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;
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;
спасибо всем огромное, кто принимал участие в решении этой задачи!!!