Loydova osmička je hlavolam s osmi čverečky v matici 3x3 a jedním prázdným místem. Cílem je uspořádat čtverečky do základní konfigurace (1, 2, 3; 4, 5, 6; 7, 8, prázdno). Normálně to je Loydova patnáctka, ale princip je stejný. Mimochodem, nevymyslel to Loyd, 
více třeba na Wikipedii, ten na tom jen vydělal peníze.
Následuje Adamova implementace podle návodu ze cvičení, více v komentářích. Testováno jen ve FreePascalu?. Zkoušel jsem to ve starém TurboPascalu?, ale na ten jsou tam moc velká čísla a nelíbí se mu konstantní parametry, tak jsem se s tím raději dál nepatlal. Neměl by ale být problém to upravit. Možná se na vás bude Borland ještě zlobit za to, že ignorujete návratové hodnoty funkce (CQAddItem() vrací boolean, ale já na to kašlu, protože vím, že je to vždy TRUE), v tom případě to přiřaďte do nějaké odpadní booleovské proměnné.
program LoydovaOsmicka(input, output); { nebo trojka:), 15ka je na nas moc, FPC si moc nerozumi s 64 bity:( }
{
Pouzivam kruhovou frontu (viz CodeQueue), staci pak radove nizsi pamet (resp. nemusim porad dokola sesypavat).
Pole indexuju od nuly a prazdne misto mam take oznacene nulou. Jinak je to presne podle navodu ze cviceni.
Komentare odtud dal a identifikatory jsou anglicky. Pisu tak vzdycky, prijde mi to lepsi nez mixovat jazyky
a prznit cestinu.
Vsechna cisla mimo 1 a 0 najdete mezi konstantami na zacatku, Side muzete zmenit na 2 a odpovidajicim zpusobem
dalsi cisla, viz nize.
Procedura PermMove() by mohla byt rychlejsi, to by ale bylo zbytecne, protoze ji pouzivam jen pro rekonstrukci
tahu pri vypisu reseni. Takhle je aspon srozumitelne (snad) a kratce zapsana.
Program umi jednak resit resitelne konfigurace, jednak vypsat pocet kroku nutnych pro reseni vsech
konfiguraci. Za povsimnuti stoji, ze algoritmus je v podstate totozny a ze (tim padem) vyreseni netrivialni
konfigurace trva radove stejne dlouho jako nalezeni poctu kroku pro vsechny konfigurace.
Pokud zvolite druhou moznost, vypisou se take dve konkretni konfigurace, pro ktere je reseni nejdelsi
(StepsMax=31 kroku), a vypise se i pocet konfiguraci, pro ktere reseni neexistuje, muzete si overit,
ze je to presne polovina z celkoveho poctu (PermCodeMax+1), coz je spravne. Kazda konfigurace totiz patri
do prave jedne poloviny konfiguraci, ktere ze sebe navzajem lze ziskat soupanim ctverecku.
}
const { You change Size to 2 (four is too much:(), if you also change StepsMax to 6 and PermCodeMax to 23. }
Side = 3;
Count = Side*Side;
Max = Count-1;
NghbrMax = 3; { There are up to four neighbors per square. }
NghbrOffsets : array[0..NghbrMax] of integer = (-Side, 1, Side, -1);
PermCodeMax = 362879 {23}; { = fact(Side*Side)-1 }
CQMax = 24058; { Max queue size-1. Empirically determined:) (for 3x3). }
StepsMax = 31 {6}; { How many steps needed to solve a config at most. }
SqEmpty = 0;
type
SqNumber = SqEmpty..Max; { square number }
Perm = array[0..Max] of SqNumber;
PermCode = longint;
PermCodeNghbrs = record
count : integer;
codes : array[0..NghbrMax] of PermCode;
moves : array[0..NghbrMax] of SqNumber;
end;
CodeQueue = record
buf : array[0..CQMax] of PermCode;
head : integer; { place for newly added items }
tail : integer; { the "oldest" item }
isEmpty : boolean;
end;
function PermToCode(const p : Perm): PermCode; forward;
procedure CodeToPerm(c: PermCode; var p: Perm); forward;
procedure CodeGetNeighbors(c: PermCode; var neighbors : PermCodeNghbrs); forward;
function PermEmptyIndex(const p: Perm) : integer; forward;
procedure PermMove(var p: Perm; num : SqNumber); forward;
procedure WriteSquarePerm(p: Perm); forward;
procedure ReadSquarePerm(var p: Perm); forward;
procedure CountSteps; forward;
procedure SolveConfig; forward;
{ CodeQueue }
procedure CQMakeEmpty(var buf : CodeQueue); forward;
function CQIsFull(const buf : CodeQueue) : boolean; forward;
function CQAddItem(var buf : CodeQueue; item : PermCode) : boolean; forward;
function CQGetItem(var buf : CodeQueue; var item : PermCode) : boolean; forward;
function PermToCode(const p : Perm): PermCode;
var
i : integer;
j : integer;
used : array[0..Max] of boolean;
repeatCount : longint; { How many times in a row the same number appears at a certain position }
c : PermCode;
begin
for i := 0 to Max do
used[i] := FALSE;
c := 0;
repeatCount := 1;
for i :=2 to Max do
repeatCount := repeatCount * i;
for i := 0 to Max-1 do
begin
for j := 0 to p[i]-1 do
begin
if not used[j] then
c := c + repeatCount;
end;
used[p[i]] := TRUE;
repeatCount := repeatCount div (Max-i);
end;
PermToCode := c;
end;
procedure CodeToPerm(c: PermCode; var p: Perm);
var
i : integer;
j : integer;
k : integer;
n : integer;
used : array[0..Max] of boolean;
repeatCount : longint;
begin
for i := 0 to Max do
used[i] := FALSE;
repeatCount := 1;
for i :=2 to Max do
repeatCount := repeatCount * i;
for i := 0 to Max do
begin
n := c div repeatCount;
c := c mod repeatCount;
j := 0;
k := 0;
while j <= n do
begin
if not used[k] then
inc(j);
inc(k);
end;
dec(k);
p[i] := k;
if i <> Max then
begin
used[k] := TRUE;
repeatCount := repeatCount div (Max-i);
end;
end;
end;
function PermEmptyIndex(const p: Perm) : integer;
var
i : integer;
begin
i := 0;
while p[i] <> SqEmpty do
inc(i);
PermEmptyIndex := i;
end;
procedure CodeGetNeighbors(c: PermCode; var neighbors : PermCodeNghbrs);
var
p : Perm;
emptyIdx : integer;
nghbrIdx : integer;
i : integer;
begin
neighbors.count := 0;
CodeToPerm(c, p);
emptyIdx := PermEmptyIndex(p);
for i := 0 to NghbrMax do
begin
nghbrIdx := emptyIdx + NghbrOffsets[i];
if (nghbrIdx>=0) and (nghbrIdx<=Max) and { within bounds }
(((nghbrIdx div Side) = (emptyIdx div Side)) or
((nghbrIdx mod Side) = (emptyIdx mod Side)) { in the same row or column }
) then
begin
p[emptyIdx] := p[nghbrIdx];
p[nghbrIdx] := SqEmpty;
neighbors.codes[neighbors.count] := PermToCode(p);
neighbors.moves[neighbors.count] := p[emptyIdx];
inc( neighbors.count );
p[nghbrIdx] := p[emptyIdx];
p[emptyIdx] := SqEmpty;
end;
end;
end;
procedure PermMove(var p: Perm; num : SqNumber);
var
emptyIdx : integer;
i : integer;
n : PermCodeNghbrs;
begin
emptyIdx := PermEmptyIndex(p);
CodeGetNeighbors(PermToCode(p), n);
i := 0;
repeat
CodeToPerm(n.codes[i], p);
inc(i);
until (p[emptyIdx] = num) ; { or (i = n.count) - just for safety, not needed for valid args }
end;
procedure WriteSquarePerm(p: Perm);
var
i : integer;
j : integer;
begin
for i := 0 to Side-1 do
begin
for j := 0 to Side-1 do
begin
if p[ i*Side + j ] = SqEmpty then
write(' _')
else
write(' ', p[ i*Side + j ]); { works well for 1-digit numbers }
end;
writeln;
end;
end;
procedure ReadSquarePerm(var p: Perm);
var
i : integer;
j : integer;
begin
for i := 0 to Side-1 do
begin
write(' row ',i, '> ');
for j := 0 to Side-1 do
read(p[ i*Side + j ]);
readln;
end;
end;
{CodeQueue}
procedure CQMakeEmpty(var buf : CodeQueue);
begin
buf.head := 0;
buf.tail := 0;
buf.isEmpty := TRUE;
end;
function CQIsFull(const buf : CodeQueue) : boolean;
begin
CQIsFull := (buf.head = buf.tail) and not buf.isEmpty;
end;
function CQAddItem(var buf : CodeQueue; item : PermCode) : boolean;
begin
if not CQIsFull(buf) then
begin
buf.buf[buf.head] := item;
buf.head := (buf.head+1) mod CQMax;
if buf.isEmpty then
buf.isEmpty := FALSE;
CQAddItem := TRUE;
end
else
CQAddItem := FALSE;
end;
function CQGetItem(var buf : CodeQueue; var item : PermCode) : boolean;
begin
if not buf.isEmpty then
begin
item := buf.buf[buf.tail];
buf.tail := (buf.tail+1) mod CQMax;
if buf.tail = buf.head then
buf.isEmpty := TRUE;
CQGetItem := TRUE;
end
else
CQGetItem := FALSE;
end;
procedure CountSteps;
var
neighbors : PermCodeNghbrs;
i : longint;
p : Perm;
c1 : PermCode;
c : PermCode;
queue : CodeQueue;
codeSteps : array[0..PermCodeMax] of -1..StepsMax;
stepStats : array[-1..StepsMax] of longint;
begin
for i := 0 to PermCodeMax do
codeSteps[i] := -1;
stepStats[-1] := PermCodeMax; { target config (0 steps) not included }
for i := 0 to StepsMax do
stepStats[i] := 0;
{ Target config }
for i:=1 to Max do
p[i-1] := i;
p[Max] := SqEmpty;
c1 := PermToCode( p );
CQMakeEmpty(queue);
CQAddItem(queue, c1);
codeSteps[c1] := 0;
inc(stepStats[0]);
while CQGetItem(queue, c) do
begin
CodeGetNeighbors(c, neighbors);
for i:=0 to neighbors.count-1 do
begin
if codeSteps[ neighbors.codes[i] ] = -1 then
begin
codeSteps[ neighbors.codes[i] ] := codeSteps[c]+1;
inc( stepStats[ codeSteps[ neighbors.codes[i] ] ] );
dec( stepStats[-1] );
if codeSteps[ neighbors.codes[i] ] = StepsMax then
begin
writeln(codeSteps[ neighbors.codes[i] ], ' steps:');
CodeToPerm(neighbors.codes[i], p);
WriteSquarePerm(p);
end;
CQAddItem(queue, neighbors.codes[i]);
end
end;
end;
writeln(stepStats[-1], ' configurations are unsolvable.');
for i := 0 to StepsMax do
writeln(stepStats[i], ' configurations are solvable in ', i, ' steps.');
end;
procedure SolveConfig;
var
neighbors : PermCodeNghbrs;
i : longint;
p : Perm;
c0 : PermCode;
c1 : PermCode;
c : PermCode;
queue : CodeQueue;
codeMoves : array[0..PermCodeMax] of SqNumber;
begin
for i := 0 to PermCodeMax do
codeMoves[i] := SqEmpty;
{ Initial config }
writeln('Enter the initial configuration:');
ReadSquarePerm( p );
c0 := PermToCode( p );
writeln;
{ Target config }
for i:=1 to Max do
p[i-1] := i;
p[Max] := SqEmpty;
c1 := PermToCode( p );
CQMakeEmpty(queue);
CQAddItem(queue, c1);
while CQGetItem(queue, c) and (codeMoves[c0] = SqEmpty) do
begin
CodeGetNeighbors(c, neighbors);
for i:=0 to neighbors.count-1 do
begin
if codeMoves[ neighbors.codes[i] ] = SqEmpty then
begin
codeMoves[ neighbors.codes[i] ] := neighbors.moves[i];
CQAddItem(queue, neighbors.codes[i]);
end
end;
end;
if codeMoves[c0] = SqEmpty then
writeln('Unsolvable.')
else
begin
writeln('Solution:');
c := c0;
CodeToPerm(c, p);
i := 1;
repeat
writeln('#', i, ' Move ', codeMoves[c], ':');
PermMove(p, codeMoves[c] );
WriteSquarePerm(p);
c := PermToCode(p);
inc(i);
until c = c1;
end;
end;
var
opt : integer;
begin
writeln('Choose an option (enter one digit):');
writeln(' [1] Solve a configuration.');
writeln(' [2] Compute steps needed to solve all configurations.');
writeln;
readln(opt);
if opt = 1 then
SolveConfig
else if opt = 2 then
CountSteps
else
writeln('Unknown option.');
end.