Loydova osmička

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.