Ðîçâ'ÿçîê 2 òóðó
Ïðîãðàìíèé êîä ðîçâ'ÿçêó äðóãîãî òóðó ç ïåðåëiêîì òåñò³â
Çàäà÷à ¹2 (100 áàë³â).
Òåñò 1. n=3 (5 áàë³â)
Òåñò 2. n=4 (10 áàë³â)
Òåñò 3. n=7 (20 áàë³â)
Òåñò 4. n=8 (30 áàë³â)
Òåñò 5. n=9 (35 áàë³â)
Àâòîðñüêèé
âàð³àíò ðîçâ’ÿçêó:
program Greek;
uses crt;
type
DigitStr=array[1..100]
of 0..9;
var x: DigitStr;
n1,r,c,k,k1,i,ss,r1,c1,kl:integer;
t:array[1..10,1..10] of integer;
ff,fff:boolean;
n:1..100;
g:text;
function NextExist (var x:DigitStr):boolean;
var
i,j,k:1..100;
temp:0..0;
found:boolean;
begin
i:=n+1;
j:=n;
x[n+1]:=0;
found:=false;
while (not found) and
(i>1) do
begin
found:=x[i-1]<x[i];
if (not found) then
i:=i-1
else
k:=i-1;
end;
if found then
begin
i:=n;
while
x[i]<=x[k] do
i:=i-1;
temp:=x[i];
x[i]:=x[k];
x[k]:=temp;
i:=k+1;
while i<j do
begin
temp:=x[j];
x[j]:=x[i];
x[i]:=temp;
i:=i+1;
j:=j-1;
end;
end;
NextExist:=found;
end;
procedure InitAr(var x:DigitStr);
var i:integer;
begin
for i:=1 to n do
x[i]:=i;
end;
{}
procedure ZRow(rn:integer);
var i:integer;
begin
for i:=1 to n do
t[rn,i]:=x[i];
end;
{}
procedure ZXXX(rn:integer);
var i:integer;
begin
for i:=1 to n do
x[i]:=t[rn,i];
end;
{}
function chek(nk:integer):boolean;
var r1,c1,s,sn:integer;
mn:set of 1..10;
begin
chek:=true;
for c1:=1 to n do
begin
mn:=[];
for r1:=1 to nk do
if not (t[r1,c1] in mn) then
mn:=mn+[t[r1,c1]]
else
begin
chek:=false;
exit;
end;
end;
for r1:=1 to nk do
begin
mn:=[];
for c1:=1 to n do
if not (t[r1,c1] in mn) then
mn:=mn+[t[r1,c1]]
else
begin
chek:=false;
exit;
end;
end;
mn:=[];
for r1:=1 to nk do
if not (t[r1,r1] in mn) then
mn:=mn+[t[r1,r1]]
else
begin
chek:=false;
exit;
end;
c1:=n;
mn:=[];
for r1:=1 to nk do
begin
if not (t[r1,c1] in mn) then
mn:=mn+[t[r1,c1]]
else
begin
chek:=false;
exit;
end;
dec(c1);
end;
end;
{}
begin
clrscr;
{ write('n=>>');
readln(n);}
assign(g,'in3.txt');
reset(g);
readln(g,n);
close(g);
initar(x);
r:=1;
ZRow(r);
inc(r);
fff:=false;
ff:=true;
while ff do
begin
ff:=NextExist(x);
ZRow(r);
if chek(r) then
begin
initar(x);
inc(r);
if r>n then
begin
assign(g,'out.txt');
rewrite(g);
for r1:=1 to n do
begin
for c1:=1 to n do
write(g,t[r1,c1],' ');
writeln(g);
end;
close(g);
exit;
{ inc(kl);
writeln;}
end;
end;
if not ff then
repeat
dec(r);
ZXXX(r);
ff:=NextExist(x);
fff:=true;
until ff;
if fff then fff:=false;
end;
end.
|