program NumberSquares(input,output);
(*
  NUMBER SQUARE GAME IN TURBO-PASCAL
  AS OF BASIC VER 4.0 - 12 NOV 79
  BY MARC I. LEAVEY, M.D.
*)
type
  field        = array[1..4,1..4] of integer;
const
  Magic        : field = ((1,6,15,8),
                          (12,11,2,5),
                          (10,13,4,3),
                          (7,16,9,14));
  emptyloc     = 16;
var
  EndGame,
  TotalEnd     : boolean;
  Pleasure     : char;
  Board        : field;
  selrow,selcol: integer;

procedure InKey(var ch:char);
Begin
  repeat until keypressed;
  read(kbd,ch);
  if ch=^C then
  begin
    writeln;
    writeln;
    writeln('** Abort **');
    halt;
  end;
  ch:=upcase(ch);
End;

procedure Greeting;
Begin
  writeln('N U M B E R   S Q U A R E S');
  writeln('---------------------------');
  writeln;
  writeln('WELCOME TO THE WORLD OF');
  writeln('CONFUSION. THERE ARE TWO');
  writeln('VERSIONS OF NUMBER SQUARES:');
  writeln(' 1 - SEQUENTIAL');
  writeln(' 2 - MAGIC SQUARE');
End;

procedure SetupBoard;
var
  row,col      : integer;

  procedure SetMagic;
  (* SET UP MAGIC SQUARE BOARD *)
  begin
    Board:=Magic;
    selrow:=4;
    selcol:=2;
  end;

  procedure SetSequential;
  (* SET UP SEQUENTIAL BOARD *)
  begin
    for row:=1 to 4 do
      for col:=1 to 4 do
        Board[row,col]:=pred(row)*4+col;
    selrow:=4;
    selcol:=4;
  end;

Begin (* SetupBoard *)
  repeat
    write('WHICH IS YOUR PLEASURE ');
    InKey(Pleasure);
  until Pleasure in ['1','2'];
  case Pleasure of
    '1' : SetSequential;
    '2' : SetMagic;
  end;
End;

procedure ScrambleBoard;
(* NOW SCRAMBLE THE BOARD TWO HUNDRED TIMES *)
var
  match         : boolean;
  Scramb,dir    : integer;

  procedure GoDown;
  begin
    Board[selrow,selcol]:=Board[pred(selrow),selcol];
    Board[pred(selrow),selcol]:=emptyloc;
    selrow:=pred(selrow);
  end;

  procedure GoUp;
  begin
    Board[selrow,selcol]:=Board[succ(selrow),selcol];
    Board[succ(selrow),selcol]:=emptyloc;
    selrow:=succ(selrow);
  end;

  procedure GoLeft;
  begin
    Board[selrow,selcol]:=Board[selrow,pred(selcol)];
    Board[selrow,pred(selcol)]:=emptyloc;
    selcol:=pred(selcol);
  end;

  procedure GoRight;
  begin
    Board[selrow,selcol]:=Board[selrow,succ(selcol)];
    Board[selrow,succ(selcol)]:=emptyloc;
    selcol:=succ(selcol);
  end;

Begin (* ScrambleBoard *)
  writeln('I AM NOW SCRAMBLING THE BOARD...');
  for Scramb:=1 to 200 do
  begin
    repeat
      dir:=succ(random(4));
      case dir of
        1 : match:=selrow=1;
        2 : match:=selrow=4;
        3 : match:=selcol=1;
        4 : match:=selcol=4;
      end;
    until not match;
    case dir of
      1 : GoDown;
      2 : GoUp;
      3 : GoLeft;
      4 : GoRight;
    end;
  end;
End;

procedure PrintBoard;
var
  row,col      : integer;

  procedure line;
  begin
    writeln('-------------');
  end;

Begin (* PrintBoard *)
  line;
  for row:=1 to 4 do
  begin
    for col:=1 to 4 do
    begin
      write(':');
      if Board[row,col]=emptyloc then write('  ')
                                 else write(Board[row,col]:2);
    end;
    writeln(':');
    line;
  end;
End;

procedure InputMove;
var
  flag,
  loop         : boolean;
  myDig,
  MyRow,MyCol,
  CurRow,CurCol: integer;

  function FindNumber:boolean;
  (* Search for selected number - returns TRUE if match *)
  begin
    selrow:=0;
    selcol:=0;
    for CurRow:=1 to 4 do
    begin
      for CurCol:=1 to 4 do
      begin
        if Board[CurRow,CurCol]=myDig then
        begin
          selrow:=CurRow;
          selcol:=CurCol;
        end;
      end;
    end;
    if selrow=0 then writeln('I CAN''T FIND THAT NUMBER');
    FindNumber:=selrow<>0;
  end;

  function TestValidMove:boolean;
  (* Search for empty location - returns TRUE if empty *)
  var
    empty      : boolean;
  begin
    MyRow:=0;
    MyCol:=0;
    empty:=false;
    for CurRow:=pred(selrow) to succ(selrow) do
      if CurRow in [1..4] then
        if Board[CurRow,selcol]=emptyloc then
      begin
        MyRow:=CurRow;
        MyCol:=selcol;
        empty:=true;
      end;
    if not empty then
    begin
      for CurCol:=pred(selcol) to succ(selcol) do
        if CurCol in [1..4] then
          if Board[selrow,CurCol]=emptyloc then
        begin
          MyRow:=selrow;
          MyCol:=CurCol;
          empty:=true;
        end;
    end;
    if not empty then writeln('NOT A VALID MOVE');
    TestValidMove:=empty;
  end;

  procedure FindSequential;
  (* Test sequential solved *)
  var
    row,col,
    tile       : integer;
  begin
    tile:=0;
    loop:=true;
    for row:=1 to 4 do
      for col:=1 to 4 do
      begin
        if Board[row,col]<tile then loop:=false;
        if loop then tile:=Board[row,col];
      end;
      EndGame:=loop;
      if EndGame then writeln('YOU GOT IT!');
  end;

  procedure FindMagic;
  (* Test magic solved *)
  begin
    loop:=true;
    for CurRow:=1 to 4 do
      for CurCol:=1 to 4 do
        if Board[CurRow,CurCol]<>Magic[CurRow,CurCol] then loop:=false;
    EndGame:=loop;
    if EndGame then writeln('THAT IS THE CORRECT SOLUTION!');
  end;

  procedure Numin(var num:integer);
  var
    digit,
    endline    : boolean;
    Ms         : char;
    dig        : integer;

    procedure Digin;
    begin
      endline:=false;
      digit:=false;
      InKey(Ms);
      if (Ms=^M) then endline:=true
      else begin
             write(Ms);
             dig:=ord(Ms)-ord('0');
             if (dig in [0..9]) then digit:=true
             else begin
                    writeln;
                    writeln('** Invalid input - retry **');
                  end;
           end;
    end;

  begin (* Numin *)
    repeat
      write('MOVE WHICH PIECE ');
      num:=0;
      repeat
        repeat
          Digin;
        until endline or digit;
        if digit then num:=10*num+dig;
      until endline;
      writeln;
    until num in [1..15];
  end;

Begin (* InputMove *)
  repeat
    Numin(myDig);
    flag:=FindNumber;
    if flag then flag:=TestValidMove;
  until flag;
  Board[MyRow,MyCol]:=myDig;
  Board[selrow,selcol]:=emptyloc;
  case Pleasure of
    '1' : FindSequential;
    '2' : FindMagic;
  end;
End;

BEGIN (* MAIN *)
  EndGame:=false;
  TotalEnd:=false;
  repeat
    Greeting;
    SetupBoard;
    ScrambleBoard;
    repeat
      PrintBoard;
      InputMove;
    until EndGame;
    writeln('THAT IS THE CORRECT SOLUTION!');
    write('LIKE TO PLAY ANOTHER GAME ');
    InKey(Pleasure);
    TotalEnd:=Pleasure<>'Y';
  until TotalEnd;
END.