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.
Tohle je Adamova implementace podle návodu ze cvičení, více v komentářích:
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. Ostatni parametry pak
budou predimenzovane (pocet sousedu je pak max. 2, permutaci je jen 4!-1 atd.), ale to nevadi.
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.
Docetl jsem se, ze kazdou pozici lze vyresit v 31 krocich. Podarilo se mi ale najit nanejvys 30-krokovou:(:
8 7 6
5 4 3
2 1 0
}
const
Side = 3; { You change this to 2. Four is too much:(. }
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; { = fact(Side*Side)-1 }
CQMax = 24058; { Max queue size-1. Empirically determined:) (for 3x3). }
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;
{ 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 }
begin
for i := 0 to Max do
used[i] := FALSE;
PermToCode := 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
PermToCode := PermToCode + repeatCount;
end;
used[p[i]] := TRUE;
repeatCount := repeatCount div (Max-i);
end;
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;
begin
PermEmptyIndex := 0;
while p[PermEmptyIndex] <> SqEmpty do
inc(PermEmptyIndex);
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 := low(NghbrOffsets) to high(NghbrOffsets) 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;
var
neighbors : PermCodeNghbrs;
i : longint;
p : Perm;
c0 : PermCode;
c1 : PermCode;
c : PermCode;
queue : CodeQueue;
codeMoves : array[0..PermCodeMax] of SqNumber; { TODO }
begin
for i := low(codeMoves) to high(codeMoves) 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.