Решение задачи 4.
Решение этой задачи аналогично решению предыдущей задачи со сгибанием полоски с той лишь разницей, что тут будет поочередно производится два сгибания: сначала правая половина под левую, а затем нижнюю под верхнюю
{$A-,B-,D-,E+,F-,G-,I+,L-,N-,O-,R-,S-,V-,X-}
{$M 16384,0,655360}
uses crt;
const
maxk = 6;
type
input = record
last1,last2,next1,next2,new : word;
end;
var
k,i,j,i1,i2,j1,j2,nj1,nj2,n,n1,cn,half : word;
m : array[1..1 shl maxk,1..1 shl maxk] of input;
Procedure concat(a,b,c,d : word);
var i1,i2,j1,j2,nj1,nj2 : word;
begin
i1:=a; i2:=b;
while (m[i1,i2].next1<>n+1) and (m[i1,i2].next2<>n+1) do
begin
i1:=m[i1,i2].next1; i2:=m[i1,i2].next2;
end;
j1:=c; j2:=d;
while (m[j1,j2].next1<>n+1) and (m[j1,j2].next2<>n+1) do
begin
j1:=m[j1,j2].next1; j2:=m[j1,j2].next2;
end;
while j1<>0 do
begin
nj2:=m[j1,j2].last2; nj1:=m[j1,j2].last1;
m[i1,i2].next1:=j1; m[i1,i2].next2:=j2;
m[j1,j2].last1:=i1; m[j1,j2].last2:=i2;
i1:=j1; i2:=j2; j1:=nj1; j2:=nj2;
end;
m[i1,i2].next1:=n+1; m[i1,i2].next2:=n+1;
end;
begin
Write('Введите k...');readln(k);
n:=1 shl k; {Определение числа клеток в одной строке или столбце}
n1:=n*n; {Определение числа клеток в матрице}
for i:=1 to n do
for j:=1 to n do with m[i,j] do
begin
last1:=0; next1:=n+1;
last2:=0; next2:=n+1;
new:=0;
end;
cn:=n;
while cn>1 do {сгибание матрицы}
begin
half:=cn div 2;
for i:=1 to half do {сгиб по вертикали}
for j:=1 to cn do concat(j,i,j,cn-i+1);
for i:=1 to half do {сгиб по горизонтали}
for j:=1 to half do concat(i,j,cn-i+1,j);
cn:=half;
end;
j1:=1;j2:=1;
for i:=1 to n1 do {Назначение клеткам новые номера}
begin
m[j1,j2].new:=i;
nj1:=m[j1,j2].next1; nj2:=m[j1,j2].next2;
j1:=nj1; j2:=nj2;
end;
for i:=1 to n do {Вывод результатов}
begin
for j:=1 to n do write(m[i,j].new:8);
writeln;
end;
end.
|
