program _08game;
uses crt;
type
  tgame=record
    pos:array[1..4,1..4] of byte; {where 0 = hole, 1..15 = cards}
    holex,holey:byte;             {position of the hole}
  end;
var
  initpos:tgame;                {initial placement}
  issolution:boolean;           {does a solution exist?}
const
  finlpos:tgame=(pos:((1,5,9,13),(2,6,10,14),(3,7,11,15),(4,8,12,0));
    holex:4;holey:4);           {final placement; this is default}

procedure help;                 {give a help}
begin
  textattr:=lightgray;
  writeln;
  writeln('Syntax: 08game [switch] <file1> [file2]');
  writeln;
  writeln(' where: switch = -solve or -show');
  writeln('        file1  = initial placement');
  writeln('        file2  = final placement');
end;

procedure error(no:byte;s:string);      {it was error, give a message and}
begin                                   {exit to DOS}
  writeln;
  textattr:=lightred;
  case no of
    1:writeln('File ',s,' not found.');
    2:writeln('File ',s,' is bad.');
    3:begin writeln('Bad parameter (',s,').'); help; end;
    4:begin
        writeln('First parameter must be a switch if 3 parameters given.');
        help;
      end;
    5:begin writeln('Too many parameters.'); help; end;
    6:begin writeln('Missing filename.'); help; end;
  end;
  textattr:=lightgray;
  writeln;
  halt;
end;

procedure spcout(var s:string);         {delete spaces at begin and end}
begin                                   {of string}
  while s[length(s)]=#32 do dec(s[0]);
  while (length(s)>0) and (s[1]=#32) do s:=copy(s,2,255);
end;

procedure readpos(fname:string;var posg:tgame); {read from file "fname"}
var                                             {placement to "posg"}
  t:text;
  s:string;
  s2:string[5];
  hlp1,x,y:byte;                        {x,y = actual pos. in playing desk}
  isitok:integer;
  cntrl:array[0..15] of boolean;        {a list of used numbers}
begin
  fillchar(cntrl,sizeof(cntrl),0);      {no number used yet}
  x:=0; y:=1;
  assign(t,fname);
  {$I-}
  reset(t);
  if ioresult<>0 then error(1,fname);
  repeat
    if seekeof(t) then error(2,fname);  {unexpected EOF?}
    readln(t,s);
    if ioresult<>0 then error(2,fname);
    spcout(s);                          {delete unwanted spaces}
    while length(s)>0 do                {scan all numbers in "s"}
    begin
      hlp1:=pos(#32,s);                 {find the first space}
      if hlp1=0 then hlp1:=length(s)+1;
      s2:=copy(s,1,hlp1-1);             {separated number to "s2"}
      s:=copy(s,hlp1+1,255);
      spcout(s);                        {delete unwanted spaces}
      if (s2='x') or (s2='X') then hlp1:=0 {is it hole?}
      else begin
        val(s2,hlp1,isitok);            {no => convert it to number}
        if (isitok<>0) or not (hlp1 in [1..15]) then error(2,fname);
      end;
      if cntrl[hlp1] then error(2,fname); {if already used, display error}
      cntrl[hlp1]:=true;                {mark it as used}
      inc(x);
      if x>4 then begin x:=1; inc(y); end;
      posg.pos[x,y]:=hlp1;              {write a card to playing desk}
      if hlp1=0 then                    {it is hole, store its position}
      begin
        posg.holex:=x;
        posg.holey:=y;
      end;
      if (x=4) and (y=4) then break;    {if all cards read, go away}
    end;
  until (x=4) and (y=4);                {if all cards read, go away}
  {$I+}
  close(t);
end;

function canbesolved(posg:tgame):boolean;       {can be reach the default}
                                                {(not final!) placement?}
{Description of algorithm:
 1) The hole is moved to lower right corner.
 2) The playing desk is scanned (row by row) and if there is found a number
    at incorrect place, it is exchanged with right number. The exchanges
    are counted.
 3) If the total number of exchanges is odd, the problem cannot be solve.
}
var
  i1,i2,i3,i4:byte;
  xchgs,hlp1:byte;      {xchgs = number of exchanges}
  endit:boolean;
begin
  with posg do          {move the hole to lower right corner}
  begin
    for i1:=holex+1 to 4 do pos[i1-1,holey]:=pos[i1,holey];
    for i1:=holey+1 to 4 do pos[4,i1-1]:=pos[4,i1];
    pos[4,4]:=0;
  end;
  xchgs:=0;             {no exchanges yet}
  for i2:=1 to 4 do
    for i1:=1 to 4 do
  begin
    hlp1:=(i2-1)*4+i1;
    if posg.pos[i1,i2]<>hlp1 then       {number at incorrect place?}
    begin
      endit:=false;
      for i3:=1 to 4 do                 {find the right number...}
      begin
        for i4:=i2 to 4 do if posg.pos[i3,i4]=hlp1 then
        begin
          posg.pos[i3,i4]:=posg.pos[i1,i2];     {...and exchange it}
          posg.pos[i1,i2]:=hlp1;
          inc(xchgs);
          endit:=true;
          break;
        end;
        if endit then break;
      end;
    end;
  end;
  canbesolved:=not odd(xchgs);          {if "xchgs" is even, it can be solved}
end;

function isitdone:boolean;      {is it true, that "initpos=finlpos"?}
var
  i1,i2:byte;
  bad:boolean;
begin
  bad:=false;
  for i1:=1 to 4 do
  begin
    for i2:=1 to 4 do if initpos.pos[i1,i2]<>finlpos.pos[i1,i2] then
    begin
      bad:=true;
      break;
    end;
    if bad then break;
  end;
  isitdone:=not bad;
end;

procedure drawcard(no,x,y,colr:byte);   {draw a card with number "no"}
begin                                   {at [x,y] with color "colr"}
  textattr:=0;
  gotoxy(x,y);
  if no<>0 then textattr:=colr;         {if hole, always black}
  write('ÜÜÜÜÜÜ');
  gotoxy(x,y+1);
  if no<>0 then textattr:=colr*16+white;
  write('  ',no:2,'  ');
  if no<>0 then textattr:=lightgray;
  write('Û');
  gotoxy(x,y+2);
  if no<>0 then textattr:=colr;
  write('ß');
  if no<>0 then textattr:=lightgray*16+colr;
  write('ßßßßß ');
  gotoxy(1,1);
end;

var
  moves:word;   {number of moves}

procedure swapcardhole(x,y:byte);       {swap card [x,y] with the hole,}
begin                                   {draw it and increment moves}
  with initpos do
  begin
    pos[holex,holey]:=pos[x,y];
    pos[x,y]:=0;
    drawcard(pos[holex,holey],(holex-1)*8+2,(holey-1)*3+5,blue);
    drawcard(pos[x,y],(x-1)*8+2,(y-1)*3+5,blue);
    holex:=x;
    holey:=y;
  end;
  inc(moves);
  textattr:=lightgray;
  gotoxy(72,20);
  write(moves);
  gotoxy(1,1);
end;

procedure drawsolution;         {play a game}
var
  i1,i2:byte;
  key:char;
begin
  textmode(co80);
  textattr:=0;
  write(' ');
  textattr:=white;
  gotoxy(6,2);
  write('The main playing desk:');
  gotoxy(48,2);
  write('You should reach this state');
  gotoxy(48,3);
  if issolution then write('(it is possible):')
  else write('(but it is impossible):');
  gotoxy(65,20);
  write('Moves: ');
  textattr:=lightgray;
  write('0');
  for i2:=1 to 4 do
    for i1:=1 to 4 do
      drawcard(initpos.pos[i1,i2],(i1-1)*8+2,(i2-1)*3+5,blue);
  for i2:=1 to 4 do
    for i1:=1 to 4 do
      drawcard(finlpos.pos[i1,i2],(i1-1)*8+46,(i2-1)*3+5,green);
  moves:=0;
  repeat
    key:=readkey;
    if key=#0 then
    with initpos do begin
      key:=readkey;
      case key of
        #72{^ }:if holey<4 then swapcardhole(holex,holey+1);
        #80{v }:if holey>1 then swapcardhole(holex,holey-1);
        #75{<-}:if holex<4 then swapcardhole(holex+1,holey);
        #77{->}:if holex>1 then swapcardhole(holex-1,holey);
      end;
    end
    else if key=#27{Esc} then break;
    if isitdone then
    begin
      gotoxy(16,22);
      textattr:=lightred+blink;
      writeln('Wow! You solved it! You are the hero! I love you!');
      gotoxy(1,1);
      readkey;
      break;
    end;
  until false;
  textmode(co80);
end;

procedure upstring(var s:string);       {convert a string to uppercase}
var
  i1:byte;
begin
  for i1:=1 to length(s) do s[i1]:=upcase(s[i1]);
end;

var
  solvep,showp,finalp:boolean;          {parameters from command line}
  fninit,fnfinal:string;                {names of files}
begin
  if paramcount=0 then                  {no parameters => give a help}
  begin
    help;
    halt;
  end;
  if paramcount=1 then                  {one parameter}
  begin
    fninit:=paramstr(1);
    if fninit[1]='-' then error(6,'');  {it must be a filename}
  end
  else if paramcount=2 then             {two parameters}
  begin
    fninit:=paramstr(1);
    if fninit[1]='-' then               {1st parameter can be a switch...}
    begin
      upstring(fninit);
      if fninit='-SOLVE' then solvep:=true
      else if fninit='-SHOW' then showp:=true
      else error(3,fninit);
      fninit:=paramstr(2);
    end
    else begin                          {...or a filename}
      fnfinal:=paramstr(2);
      finalp:=true;
    end;
  end
  else if paramcount=3 then             {three parameters}
  begin
    fninit:=paramstr(1);
    if fninit[1]<>'-' then error(4,''); {1st parameter must be a switch}
    upstring(fninit);
    if fninit='-SOLVE' then solvep:=true
    else if fninit='-SHOW' then showp:=true
    else error(3,fninit);
    fninit:=paramstr(2);
    fnfinal:=paramstr(3);
    finalp:=true;
  end
  else error(5,'');                     {more then three parameters}
  readpos(fninit,initpos);              {read initial placement}
  if finalp then readpos(fnfinal,finlpos); {read final placement if needed}
  {now check if it is possible to reach final placement from initial:}
  issolution:=canbesolved(initpos)=canbesolved(finlpos);
  {If from both initial and final placement is possible to reach the default
  placement, it is also possible to reach from initial to final placement.
  Also, if from both initial and final placement is NOT possible to reach the
  default placement, it is possible to reach from initial to final placement
  too. (Because every such placement can be transformed to placement which
  is the same as default placement except two numbers (they are swapped)).
  }
  if not solvep and not showp then      {no switch given}
  begin
    writeln;
    write('The answer you want is: ');
    textattr:=lightgreen;
    if issolution then
      writeln('Yes, there exists a solution.')
    else writeln('No, a solution does not exist.');
    textattr:=lightgray;
    writeln;
    halt;
  end;
  if solvep then                        {switch -solve given}
  begin
    writeln;
    if not issolution then
    begin
      writeln('There is no way to reach the final placement from initial placement.');
      writeln('If you don''t believe me try the -show parameter.');
      writeln;
      halt;
    end;
    writeln('This program does not support solution of the problem.');
    writeln('But the -show parameter is fully functionally.');
    writeln('Please try the -show parameter for detailed info.');
    writeln;
    halt;
  end;
  if showp then                         {switch -show given}
  begin
    writeln;
    writeln('This program does not support solution of the problem.');
    writeln('But, you can try it manually. Control the cards with cursor keys.');
    writeln;
    write('If you are ready, press anything (except Shift, Ctrl-Break, etc.)');
    while keypressed do readkey;        {clear keyboard buffer}
    readkey;
    while keypressed do readkey;
    drawsolution;
  end;
end.