{  #12 - Lukas Brozovsky, ICP 98  }

{$MINSTACKSIZE $00F00000}
{$MAXSTACKSIZE $00F00000}

Unit S12_U1;

Interface

Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

Type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    ListBox1: TListBox;
    Image1: TImage;
    Image2: TImage;
    Button1: TButton;
    Procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  end;
  TPuzzle = Array[1..4, 1..4] of Byte;
  TMove = (NONE, LEFT, RIGHT, UP, DOWN);

Const
  DefaultEndPos: TPuzzle = ((1,5,9,13),(2,6,10,14),(3,7,11,15),(4,8,12,0));

Var
  Form1: TForm1;
  StartPos, EndPos: TPuzzle;
  R: LongInt;

Implementation

{$R *.DFM}

{*******************************************************************************
  This procedure opens the *.POS file into the P variable. It also checks, if
the file is correct (only one X, no big numbers, every number only once) and
returns an appropriate boolean result.
*******************************************************************************}
Function OpenPos(FileName: String; var P: TPuzzle): Boolean;
Var FileLine: String;
    Check: Array[0..14] of Boolean;
    FIn: Text;
    X, Y: Byte;
    S: String;
    Ch: Char;
    OpenResult: Boolean;
begin
  FillChar(Check, SizeOf(Check), False);

  AssignFile(FIn, FileName);

  Reset(FIn);

  For Y := 1 to 4 do
  begin
    For X := 1 to 4 do
    begin
      S := '';
      Read(FIn, Ch);
      While NOT (UpCase(Ch) IN ['0'..'9','X']) do
        Read(FIn, Ch);
      If UpperCase(Ch) = 'X' then
      begin
        P[X, Y] := 0;
        Check[0] := True;
      end
      else
      begin
        S := S + Ch;
        Read(FIn, Ch);
        While Ch IN ['0'..'9'] do
        begin
          S := S + Ch;
          Read(FIn, Ch);
        end;
        P[X, Y] := StrToInt(S);
        If (P[X, Y] > 0) AND (P[X, Y] < 15) then
          Check[P[X, Y]] := True;
      end;
    end;
    If EOLn(FIn) then ReadLn(FIn);
  end;

  CloseFile(FIn);

  OpenResult := True;
  For X := 0 to 14 do
    OpenResult := OpenResult AND Check[X];
  OpenPos := OpenResult;
end;

{*******************************************************************************
  This procedure switches two cards [X1, Y1] and [X2, Y2] in the puzzle P.
*******************************************************************************}
Procedure Switch(var P: TPuzzle; X1, Y1, X2, Y2: Byte);
Var
  Tmp: Byte;
begin
  Tmp := P[X1, Y1];
  P[X1, Y1] := P[X2, Y2];
  P[X2, Y2] := Tmp;
end;

{*******************************************************************************
  This function chekcs if 2 puzzels are equal and returns true if so.
*******************************************************************************}
Function Equal(P1, P2: TPuzzle): Boolean;
Var
  X, Y: Byte;
begin
  Equal := False;
  For Y := 1 to 4 do
    For X := 1 to 4 do
      If P1[X, Y] <> P2[X, Y] then Exit;
  Equal := True;
end;

{*******************************************************************************
  This function returns number - it shows how close is puzzle A to solution (or
puzzle B). It adds up all the distances between the same cards.
*******************************************************************************}
Function HowCloseIsIt(A, B: TPuzzle): LongInt;
Var
  K, X, Y, AX, AY, BX, BY: Byte;
  S: LongInt;
begin
  S := 0;
  For K := 0 to 14 do
  begin
    For Y := 1 to 4 do
      For X := 1 to 4 do
      begin
        If A[X, Y] = K then
        begin
          AX := X;
          AY := Y;
        end;
        If B[X, Y] = K then
        begin
          BX := X;
          BY := Y;
        end;
      end;
    Inc(S, Abs(AX - BX) + Abs(AY - BY))
  end;

  HowCloseIsIt := S;
end;

{*******************************************************************************
  This one tests if the puzzle is solvable. I'm switching cards together to get
the final puzzle. When I switsch 2 numbers I change the Possible value. When I
switch number with a empty place I do NOT change the Possible value. After I
transform one puzzle into the other - the Possible value shows if it's possible.
*******************************************************************************}
Function TestIt(PStart, PFinal: TPuzzle): Boolean;
Var
  I, X, Y, MyX, MyY, FinalX, FinalY: Byte;
  Possible: Boolean;
begin
  Possible := True;
  For I := 0 to 14 do
  begin
    If I = 1 then Possible := True;
    For Y := 1 to 4 do
      For X := 1 to 4 do
        If PStart[X, Y] = I then
        begin
          MyX := X;
          MyY := Y;
        end;
    For Y := 1 to 4 do
      For X := 1 to 4 do
        If PFinal[X, Y] = I then
        begin
          FinalX := X;
          FinalY := Y;
        end;
    While FinalX < MyX do
    begin
      If PStart[MyX - 1, MyY] <> 0 then
        Possible := NOT Possible;
      Switch(PStart, MyX, MyY, MyX - 1, MyY);
      Dec(MyX);
    end;
    While FinalX > MyX do
    begin
      If PStart[MyX + 1, MyY] <> 0 then
        Possible := NOT Possible;
      Switch(PStart, MyX, MyY, MyX + 1, MyY);
      Inc(MyX);
    end;
    While FinalY < MyY do
    begin
      If PStart[MyX, MyY - 1] <> 0 then
        Possible := NOT Possible;
      Switch(PStart, MyX, MyY, MyX, MyY - 1);
      Dec(MyY);
    end;
    While FinalY > MyY do
    begin
      If PStart[MyX, MyY + 1] <> 0 then
        Possible := NOT Possible;
      Switch(PStart, MyX, MyY, MyX, MyY + 1);
      Inc(MyY);
    end;
  end;

  TestIt := Possible;
end;

{*******************************************************************************
  This procedure is trying to solve the puzzle - It deosn't always find the
optimal solution and it can ran out of stack. But it can get over 100's of
shifts. It's bassicaly BFS (breath-first-search = "hledani do sirky") with a
touch of heuristic?
*******************************************************************************}
Procedure Solve(PStart, PFinal: TPuzzle);
Type
  TQOne = record
    State: TPuzzle;
    Shifts, From, Score, Index: LongInt;
    Moved: TMove;
    ZX, ZY: Byte;
  end;
Var
  Done: Boolean;
  Q: Array[1..20000] of TQOne;
  C, Q1, Q2, I, J, NewI: LongInt;
  Finish: TQOne;
  X, Y: Byte;
  T: Boolean;

  Procedure BubbleIt(J: LongInt);
  Var Tmp: TQOne;
  begin

    {If you uncomment this part it will always find the optimal solution, but
     it doesn't reach very deep: 10 - 30 shifts ? }

    While {(Q[J-1].Shifts = Q[J].Shifts) AND} (Q[J - 1].Score > Q[J].Score) AND (J > Q1 + 1) do
    begin
      Tmp := Q[J];
      Q[J] := Q[J - 1];
      Q[J - 1] := Tmp;
      Dec(J);
    end;
  end;

begin
  Done := False;
  Q1 := 0; Q2 := 1;
  With Q[1] do
  begin
    State := PStart;
    Moved := NONE;
    Shifts := 0;
    Index := 1;
    Score := HowCloseIsIt(State, PFinal);
    From := 0;
    For X := 1 to 4 do
      For Y := 1 to 4 do
        If State[X, Y] = 0 then
        begin
          ZX := X;
          ZY := Y;
        end;
  end;

  NewI := 2;
  While (NOT Done) AND (Q2 < 19500) do
  begin
    Form1.Label2.Caption := IntToStr(Q1);
    Form1.Label3.Caption := IntToStr(Q2);

    Inc(Q1);
    With Q[Q1] do
    begin
      Case ZX of
        1:
        begin
          If Moved <> LEFT then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].ZX := ZX + 1;
            Q[Q2].ZY := ZY;
            Q[Q2].Moved := RIGHT;
            Switch(Q[Q2].State, ZX, ZY, ZX + 1, ZY);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;

            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
        end;
        2, 3:
        begin
          If Moved <> LEFT then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].From := Index;
            Q[Q2].ZX := ZX + 1;
            Q[Q2].ZY := ZY;
            Q[Q2].Moved := RIGHT;
            Switch(Q[Q2].State, ZX, ZY, ZX + 1, ZY);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
          If Moved <> RIGHT then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].ZX := ZX - 1;
            Q[Q2].ZY := ZY;
            Q[Q2].Moved := LEFT;
            Switch(Q[Q2].State, ZX, ZY, ZX - 1, ZY);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
        end;
        4:
        begin
          If Moved <> RIGHT then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].ZX := ZX - 1;
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].ZY := ZY;
            Q[Q2].Moved := LEFT;
            Switch(Q[Q2].State, ZX, ZY, ZX - 1, ZY);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
        end;
      end;
      Case ZY of
        1:
        begin
          If Moved <> UP then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].ZX := ZX;
            Q[Q2].ZY := ZY + 1;
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].Moved := DOWN;
            Switch(Q[Q2].State, ZX, ZY, ZX, ZY + 1);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
        end;
        2, 3:
        begin
          If Moved <> UP then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].ZX := ZX;
            Q[Q2].ZY := ZY + 1;
            Q[Q2].Moved := DOWN;
            Switch(Q[Q2].State, ZX, ZY, ZX, ZY + 1);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
          If Moved <> DOWN then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].ZX := ZX;
            Q[Q2].ZY := ZY - 1;
            Q[Q2].Moved := UP;
            Switch(Q[Q2].State, ZX, ZY, ZX, ZY - 1);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
        end;
        4:
        begin
          If Moved <> DOWN then
          begin
            Inc(Q2);
            Q[Q2].State := State;
            Q[Q2].From := Index;
            Q[Q2].Index := NewI; Inc(NewI);
            Q[Q2].Shifts := Shifts + 1;
            Q[Q2].ZX := ZX;
            Q[Q2].ZY := ZY - 1;
            Q[Q2].Moved := UP;
            Switch(Q[Q2].State, ZX, ZY, ZX, ZY - 1);
            Q[Q2].Score := HowCloseIsIt(Q[Q2].State, PFinal);
            T := True;
            For I := 1 to Q1 - 1 do
              If Equal(Q[I].State, Q[Q2].State) then
              begin
                Dec(Q2);
                T := False;
                Break;
              end;
            If T then
            begin
              If Equal(Q[Q2].State, PFinal) then
              begin
                Done := True;
                Finish := Q[Q2];
              end;
              BubbleIt(Q2);
            end;
          end;
        end;
      end;
    end;
  end;

  For J := 1 to Q1 do
      If Finish.Index = Q[I].From then
      begin
        I := J;
        Break;
      end;
  C := 1;
  Case Finish.Moved of
   LEFT: Form1.ListBox1.Items.Insert(0, 'LEFT');
   RIGHT: Form1.ListBox1.Items.Insert(0, 'RIGHT');
   UP: Form1.ListBox1.Items.Insert(0, 'UP');
   DOWN: Form1.ListBox1.Items.Insert(0, 'DOWN');
  end;
  While Q[I].From > 0 do
  begin
    Case Q[I].Moved of
      LEFT: Form1.ListBox1.Items.Insert(0, 'LEFT');
      RIGHT: Form1.ListBox1.Items.Insert(0, 'RIGHT');
      UP: Form1.ListBox1.Items.Insert(0, 'UP');
      DOWN: Form1.ListBox1.Items.Insert(0, 'DOWN');
    end;
    Inc(C);
    For J := 1 to Q1 do
      If Q[J].Index = Q[I].From then
      begin
        I := J;
        Break;
      end;
  end;
  Form1.ListBox1.Items.Insert(0, IntToStr(C) + ' shifts');
  R := C;
end;

{*******************************************************************************
  This procedure shows the puzzle into Image1 or Image2 (A).
*******************************************************************************}
Procedure ShowPuzzle(P: TPuzzle; A: Byte);
Var
  X, Y: Byte;
begin
  If A = 1 then
    With Form1.Image1.Canvas do
    begin
      FillRect(Rect(0, 0, 80, 80));
      For Y := 1 to 4 do
        For X := 1 to 4 do
          TextOut(X * 20 - 15, Y * 20 - 15, IntToStr(P[X, Y]));
    end
  else
    With Form1.Image2.Canvas do
    begin
      FillRect(Rect(0, 0, 80, 80));
      For Y := 1 to 4 do
        For X := 1 to 4 do
          TextOut(X * 20 - 15, Y * 20 - 15, IntToStr(P[X, Y]));
    end
end;

{*******************************************************************************
  This procedure decides what to do (to only check if solution exists or to
solve the puzzle or to show it graphically.
*******************************************************************************}
Procedure TForm1.FormCreate(Sender: TObject);
begin
  Case ParamCount of
    1:
    begin
      If NOT OpenPos(ParamStr(1), StartPos) then
      begin
        Label1.Caption := 'Bad input file ...';
        Exit;
      end;
      Label8.Caption := ParamStr(1);
      EndPos := DefaultEndPos;
      If TestIt(StartPos, EndPos) then
        Label1.Caption := 'It is possible ...'
      else
        Label1.Caption := 'It is NOT possible ...';
    end;
    2:
    begin
      If ParamStr(1) = '-solve' then
      begin
        If NOT OpenPos(ParamStr(2), StartPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label8.Caption := ParamStr(2);
        EndPos := DefaultEndPos;
        If TestIt(StartPos, EndPos) then
        begin
          Label1.Caption := 'It is possible ...';
          Solve(StartPos, EndPos);
        end
        else
          Label1.Caption := 'It is NOT possible ...';
      end
      else If ParamStr(1) = '-show' then
      begin
        If NOT OpenPos(ParamStr(2), StartPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label8.Caption := ParamStr(2);
        EndPos := DefaultEndPos;
        If TestIt(StartPos, EndPos) then
        begin
          Label1.Caption := 'It is possible ...';
          Solve(StartPos, EndPos);
        end
        else
          Label1.Caption := 'It is NOT possible ...';

        Button1.Enabled := True;
      end
      else
      begin
        If NOT OpenPos(ParamStr(1), StartPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        If NOT OpenPos(ParamStr(2), EndPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label8.Caption := ParamStr(1);
        Label9.Caption := ParamStr(2);
        If TestIt(StartPos, EndPos) then
          Label1.Caption := 'It is possible ...'
        else
          Label1.Caption := 'It is NOT possible ...';
      end;
    end;
    3:
    begin
      If ParamStr(1) = '-solve' then
      begin
        If NOT OpenPos(ParamStr(2), StartPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label8.Caption := ParamStr(2);
        If NOT OpenPos(ParamStr(3), EndPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label9.Caption := ParamStr(3);

        If TestIt(StartPos, EndPos) then
        begin
          Label1.Caption := 'It is possible ...';
          Solve(StartPos, EndPos);
        end
        else
          Label1.Caption := 'It is NOT possible ...';
      end
      else If ParamStr(1) = '-show' then
      begin
        If NOT OpenPos(ParamStr(2), StartPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label8.Caption := ParamStr(2);
        If NOT OpenPos(ParamStr(3), EndPos) then
        begin
          Label1.Caption := 'Bad input file ...';
          Exit;
        end;
        Label9.Caption := ParamStr(3);

        EndPos := DefaultEndPos;
        If TestIt(StartPos, EndPos) then
        begin
          Label1.Caption := 'It is possible ...';
          Solve(StartPos, EndPos);
        end
        else
          Label1.Caption := 'It is NOT possible ...';

        Button1.Enabled := True;
      end

    end;
  end;

  ShowPuzzle(StartPos, 1);
  ShowPuzzle(EndPos, 2);
end;


{*******************************************************************************
  This proc. shows the result as a movie ... ?
*******************************************************************************}
Procedure TForm1.Button1Click(Sender: TObject);
Var
  I: LongInt;
  P: TPuzzle;
  X, Y, ZX, ZY: Byte;
  U: LongInt;
begin
  P := StartPos;

  For X := 1 to 4 do
    For Y := 1 to 4 do
      If P[X, Y] = 0 then
      begin
        ZX := X;
        ZY := Y;
        Break;
      end;

  ShowPuzzle(P, 1);
  I := 1;
  While I <= R do
  begin
    If ListBox1.Items[I] = 'LEFT' then
    begin
      Switch(P, ZX, ZY, ZX - 1, ZY);
      Dec(ZX);
      ShowPuzzle(P, 1);
    end;
    If ListBox1.Items[I] = 'RIGHT' then
    begin
      Switch(P, ZX, ZY, ZX + 1, ZY);
      Inc(ZX);
      ShowPuzzle(P, 1);
    end;
    If ListBox1.Items[I] = 'UP' then
    begin
      Switch(P, ZX, ZY, ZX, ZY - 1);
      ShowPuzzle(P, 1);
      Dec(ZY);
    end;
    If ListBox1.Items[I] = 'DOWN' then
    begin
      Switch(P, ZX, ZY, ZX, ZY + 1);
      Inc(ZY);
      ShowPuzzle(P, 1);
    end;
    Inc(I);
    For U := 1 to 1000 do
      Image1.Repaint;
  end;
end;

end.