Az alábbi letöltési lehetőségek közül választhatsz: (
segítség)
Típus: text/plain
Tartalmaz szöveget
Karakterkódolás: utf-8
Méret: 4 KB
program p15;
const step_limit = 40;
type tabla = Record
t : array[1..16] of byte;
empty : byte;
end;
var states : array[0..100] of tabla;
alap : tabla;
procedure beolvas(fname : string);
var inp : text;
i : byte;
begin
assign(inp,fname);
reset(inp);
with states[1] do
begin
readln(inp, t[1], t[2], t[3], t[4]);
readln(inp, t[5], t[6], t[7], t[8]);
readln(inp, t[9], t[10], t[11], t[12]);
readln(inp, t[13], t[14], t[15], t[16]);
for i := 1 to 16 do
if t[i] = 0 then empty := i;
end;
close(inp);
alap := states[1];
end;
procedure kirak(st : tabla);
begin
with st do
begin
writeln(t[1]:3, t[2]:3, t[3]:3, t[4]:3);
writeln(t[5]:3, t[6]:3, t[7]:3, t[8]:3);
writeln(t[9]:3, t[10]:3, t[11]:3, t[12]:3);
writeln(t[13]:3, t[14]:3, t[15]:3, t[16]:3);
end;
end;
function f_ok(ta : tabla):boolean;
begin
f_ok := (ta.empty > 4);
end;
procedure f_step(var ta : tabla);
var poz : byte;
begin
poz := ta.empty - 4;
ta.t[ta.empty] := ta.t[poz]; ta.t[poz] := 0;
ta.empty := poz;
end;
function l_ok(ta : tabla):boolean;
begin
l_ok := (ta.empty < 13);
end;
procedure l_step(var ta : tabla);
var poz : byte;
begin
poz := ta.empty + 4;
ta.t[ta.empty] := ta.t[poz]; ta.t[poz] := 0;
ta.empty := poz;
end;
function b_ok(ta : tabla):boolean;
begin
b_ok := ((ta.empty mod 4) <> 1);
end;
procedure b_step(var ta : tabla);
var poz : byte;
begin
poz := ta.empty - 1;
ta.t[ta.empty] := ta.t[poz]; ta.t[poz] := 0;
ta.empty := poz;
end;
function j_ok(ta : tabla):boolean;
begin
j_ok := ((ta.empty mod 4) <> 0);
end;
procedure j_step(var ta : tabla);
var poz : byte;
begin
poz := ta.empty +1;
ta.t[ta.empty] := ta.t[poz]; ta.t[poz] := 0;
ta.empty := poz;
end;
function check:boolean;
var i,j,sor,oszlop : byte;
inverzio : integer;
begin
inverzio := 0;
alap.t[alap.empty] := 16;
for i:= 1 to 15 do
for j := i+1 to 16 do
if alap.t[i] > alap.t[j] then inc(inverzio);
sor := ((alap.empty - 1) DIV 4 ) + 1;
oszlop := ((alap.empty -1) MOD 4 ) + 1;
inverzio := inverzio + Abs(sor-4) + Abs(oszlop-4);
check := ((inverzio mod 2) = 0);
alap.t[alap.empty] := 0;
end;
function is_sol:boolean;
var i : byte;
begin
i := 1;
while (i < 16) and (alap.t[i] = i) do inc(i);
is_sol := (i = 16);
end;
procedure megold;
var steps : array[1..100] of byte;
sdb : byte;
i : byte;
function equal(s1,s2: tabla):boolean;
var i : byte;
eq : boolean;
begin
eq := true;
for i := 1 to 16 do
if s1.t[i] <> s2.t[i] then eq := false;
equal := eq;
end;
function ok_step:boolean;
var state : tabla;
ok0 : boolean;
j : byte;
begin
state := alap;
case steps[sdb] of
1 : begin
ok0 := (sdb<=step_limit) and f_ok(alap);
if ok0 then f_step(state);
end;
2 : begin
ok0 := (sdb<=step_limit) and j_ok(alap);
if ok0 then j_step(state);
end;
3 : begin
ok0 := (sdb<=step_limit) and l_ok(alap);
if ok0 then l_step(state);
end;
4 : begin
ok0 := (sdb<=step_limit) and b_ok(alap);
if ok0 then b_step(state);
end;
end;
if ok0 then
begin
for j := 1 to sdb do
if equal(states[j],state) then ok0 := false;
end;
ok_step := ok0;
end;
procedure do_step;
begin
case steps[sdb] of
1 : f_step(alap);
2 : j_step(alap);
3 : l_step(alap);
4 : b_step(alap);
end;
states[sdb+1] := alap;
end;
procedure print_sol;
var j : byte;
begin
for j := 1 to sdb-1 do
case steps[j] of
1 : write('F');
2 : write('J');
3 : write('L');
4 : write('B');
end;
writeln;
for j := 1 to sdb do
begin
kirak(states[j]);
writeln;
end;
end;
begin
writeln('Megoldás...');
for i := 1 to 100 do steps[i] := 0;
sdb := 1;
while (not is_sol) and (sdb >= 1) do
begin
repeat
inc(steps[sdb]);
until (steps[sdb] > 4) or ok_step;
if steps[sdb] <= 4
then begin
do_step;
inc(sdb);
end else begin
steps[sdb] := 0;
alap := states[sdb-1];
dec(sdb);
end;
end;
if sdb > 0 then print_sol;
end;
begin
beolvas('puzzle06.in');
kirak(alap);
if not check
then writeln('Nincs megoldás.')
else megold;
end.
