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.

  Adapted and optimized for the JOYCE PCW machine by W.Cirsovius
*)

type
  field        = array[1..4,1..4] of integer;
  Mstr         = string[80];
const
(* JOYCE special characters *)
  horch        = #$8a;           (* Horizontal line      *)
  verch        = #$85;           (* Vertical line        *)

  ul           = $86;            (* Upper left corner    *)
  vc           = $87;            (* Horizontal delimiter *)
  ll           = $83;            (* Lower left corner    *)
(* ------------------------ *)
  esc          = #$1b;
  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 underline_on;
Begin
  write(esc,'r');
End;

procedure underline_off;
Begin
  write(esc,'u');
End;

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

procedure Greeting;
Begin
  clrscr;
  underline_on;
  writeln('N U M B E R   S Q U A R E S');
  underline_off;
  writeln;
  writeln('WELCOME TO THE WORLD OF CONFUSION.');
  writeln('THERE ARE TWO 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
    gotoxy(1,10);
    clreol;
    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 GoDir(dirrow,dircol:integer);
  begin
    Board[selrow,selcol]:=Board[selrow+dirrow,selcol+dircol];
    Board[selrow+dirrow,selcol+dircol]:=emptyloc;
    selrow:=selrow+dirrow;
    selcol:=selcol+dircol;
  end;

Begin (* ScrambleBoard *)
  gotoxy(1,10);
  clreol;
  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 : GoDir(-1,0);
      2 : GoDir(+1,0);
      3 : GoDir(0,-1);
      4 : GoDir(0,+1);
    end;
  end;
End;

(* =========================== *)
(* Special JOYCE imlementation *)
(* =========================== *)
procedure PrintBoard;
var
  i,j          : integer;

  procedure line(ch:byte);
  var
    x          : integer;

    procedure hor(off:byte);
    begin
      write(horch,horch,chr(ch+off));
    end;

(*
  JOYCE info:

  ch   is left character
  ch+6 is right character
  ch+8 is horizontal character
*)

  begin (* line *)
    write(chr(ch));
    for x:=1 to 3 do hor(8);
    hor(6);
    writeln;
  end;

  procedure vertical;
  var
    x          : integer;

  procedure PrNum;
  var
    piece      : integer;
  begin
    write(verch);
    piece:=Board[i,j];
    j:=succ(j);
    if j=succ(4) then
    begin
      i:=succ(i);
      j:=1;
    end;
    if piece=emptyloc then write('  ')
                      else write(piece:2);
    end;

  begin (* vertical *)
    for x:=1 to 4 do PrNum;
    writeln(verch);
  end;

Begin (* PrintBoard *)
  clrscr;
  i:=1;
  j:=1;
  line(ul);
  vertical;
  line(vc);
  vertical;
  line(vc);
  vertical;
  line(vc);
  vertical;
  line(ll);
End;
(* =========================== *)

procedure StatusMessage(msg:Mstr);
Begin
  gotoxy(1,15);
  clreol;
  write(msg);
End;

procedure TellInvalid(msg:Mstr);
Begin
  StatusMessage(msg);
  delay(2000);
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 TellInvalid('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 TellInvalid('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 StatusMessage('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 StatusMessage('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 TellInvalid('** Invalid input - retry **');
                      end;
    end;

  begin (* Numin *)
    repeat
      StatusMessage('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;
  gotoxy((3*selcol)-1,2*selrow);
  write('  ');
  gotoxy((3*MyCol)-1,2*MyRow);
  write(myDig:2);
  case Pleasure of
    '1' : FindSequential;
    '2' : FindMagic;
  end;
End;

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