Реализовать игру "Морской бой" - Pascal ABC

uses CRT;
 
type TPole = array[1..10,1..10] of ShortInt;
var Pole: TPole;
 
procedure Init (var Pole: TPole);
var X, Y: Integer;
begin
  Randomize;
  for X := 1 to 10 do
    for Y := 1 to 10 do
      Pole[X,Y] := -1;
end; {proc Init}
 
function Freedom (x, y: Integer; Pole: TPole): Boolean;
const d: array[1..8,1..2] of Integer =
      ((0,1),(1,0),(0,-1),(-1,0),(1,1),(-1,1),(1,-1),(-1,-1));
var i: Integer;
    dx, dy: Integer;
begin
  if (x > 0) and (x < 11) and (y > 0) and (y < 11) and (Pole[x,y] = -1) then
  begin
    for i := 1 to 8 do
    begin
      dx := x + d[i,1];
      dy := y + d[i,2];
      if (dx > 0) and (dx < 11) and (dy > 0) and (dy < 11) and (Pole[dx,dy] > -1) then
      begin
        Freedom := False;
        Exit;
      end; {if}
    end; {for}
    Freedom := True;
  end else Freedom := False;
end; {func Freedom}
 
procedure Ships (var Pole: TPole);
var N, M, i: Integer;
    x, y, kx, ky: Integer;
    B: Boolean;
begin
  Init (Pole);
  for N := 3 downto 0 do
    for M := 0 to 3 - N do
    repeat
      x := Random (10) + 1;
      y := Random (10) + 1;
      kx := Random (2);
      if kx = 0 then ky := 1
                else ky := 0;
      B := True;
      for i := 0 to N do
        if not Freedom (x + kx * i, y + ky * i, Pole) then B := False;
      if B then
        for i := 0 to N do
          Pole[x+kx*i,y+ky*i] := 0;
    until B;
end; {proc Ships}
 
var Play: TPole;
    Kor: array[1..4] of Integer;
    State: Integer;
    Len: Integer;
    Pkx, Pky: Integer;
    Px, Py: Integer;
 
procedure Start;
var I: Integer;
begin
  Init (Play);
  Ships (Pole);
  State := 1;
  for I := 1 to 4 do
    Kor[I] := 5 - I;
end; {proc Start}
 
function Killed (x, y: Integer): Boolean;
var K: Char;
begin
  Write (Char (y + 64), x, ' (y/n)? ');
  repeat
    K := ReadKey;
    if K = #27 then Halt (0);
  until K in ['y','Y','n','N'];
  WriteLn (K);
  if (K = 'y') or (K = 'Y') then Killed := True
                            else Killed := False;
end; {func Killed}
 
function MaxShip: Integer;
var i: Integer;
begin
  for i := 1 to 4 do
    if Kor[i] > 0 then MaxShip := i;
end; {func MaxShip}
 
function GameOver: Boolean;
var I: Integer;
begin
  for I := 1 to 4 do
    if Kor[I] > 0 then
    begin
      GameOver := False;
      Exit;
    end; {if}
  GameOver := True;
end; {func GameOver}
 
function State1 (var x, y: Integer): Boolean;
var k, i, n, m: Integer;
    B, St: Boolean;
    tmp: Integer;
begin
  repeat
    repeat
      x := Random (10) + 1;
      y := Random (10) + 1;
    until Freedom (x, y, Play);
    Pkx := Random (2);
    Pky := Pkx - 1;
    for m := 1 to 2 do
    begin
      i := 0;
      k := 0;
      for n := 1 to 2 do
      begin
        while Freedom (x + Pkx * i, y + Pky * i, Play) do
        begin
          Inc (k);
          Inc (i);
        end; {while}
        Pkx := -Pkx;
        Pky := -Pky;
        i := 1;
      end; {for}
      B := k >= MaxShip;
      if B then Break;
      tmp := Pkx;
      Pkx := Pky;
      Pky := tmp;
    end; {for}
  until B;
  St := Killed (x, y);
  State1 := St;
  if St then
  begin
    Px := x;
    Py := y;
    Len := 1;
    if MaxShip > 1
      then State := 2
      else Dec (Kor[Len]);
  end; {if}
end; {func State1}
 
function State2 (var x, y: Integer): Boolean;
var Old: ShortInt;
    tmp: Integer;
    k: Integer;
    St: Boolean;
begin
  Old := Play[Px,Py];
  Play[Px,Py] := -1;
  repeat
    if not Freedom (Px + Pkx, Py + Pky, Play) and not Freedom (Px - Pkx, Py - Pky, Play) then
    begin
      tmp := Pkx;
      Pkx := Pky;
      Pky := tmp;
    end; {if}
    if Random (2) = 0 then
    begin
      x := Px + Pkx;
      y := Py + Pky;
    end else
    begin
      x := Px - Pkx;
      y := Py - Pky;
    end; {if}
  until Freedom (x, y, Play);
  St := Killed (x, y);
  State2 := St;
  if St then
  begin
    Len := 2;
    State := 1;
    if MaxShip > 2
      then State := 3
      else Dec (Kor[Len]);
  end else
  begin
    k := 4;
    if not Freedom (Px + 1, Py, Play) then Dec (k);
    if not Freedom (Px - 1, Py, Play) then Dec (k);
    if not Freedom (Px, Py + 1, Play) then Dec (k);
    if not Freedom (Px, Py - 1, Play) then Dec (k);
    if k < 2 then State := 1;
  end; {if}
  Play[Px,Py] := Old;
end; {func State2}
 
function State3 (var x, y: Integer): Boolean;
var Old: ShortInt;
    i: Integer;
    B, St: Boolean;
begin
  for i := 1 to 2 do
  begin
    x := Px;
    y := Py;
    while Play[x,y] = 1 do
    begin
      Inc (x, Pkx);
      Inc (y, Pky);
    end; {while}
    Old := Play[x-Pkx,y-Pky];
    Play[x-Pkx,y-Pky] := -1;
    B := Freedom (x, y, Play);
    Play[x-Pkx,y-Pky] := Old;
    if B then Break;
    Pkx := -Pkx;
    Pky := -Pky;
  end; {for}
  if B then
  begin
    St := Killed (x, y);
    State3 := St;
    if St then
    begin
      Inc (Len);
      if Len = MaxShip then
      begin
        Dec (Kor[Len]);
        State := 1;
      end; {if}
    end;
  end else
  begin
    Dec (Kor[Len]);
    State := 1;
    State3 := State1 (x, y);
  end; {if}
end; {func State3}
 
function Comput: Boolean;
var x, y: Integer;
    Kill: Boolean;
begin
  repeat
    case State of
      1: Kill := State1 (x, y);
      2: Kill := State2 (x, y);
      3: Kill := State3 (x, y);
    end; {case}
    if Kill then Play[x,y] := 1
            else Play[x,y] := -2;
  until not Kill or GameOver;
  Comput := GameOver;
end; {func Comput}
 
function Life (var Res: Boolean): Boolean;
var K1, K2: Char;
    x, y: Integer;
    B: Boolean;
begin
  repeat
    Write ('Your course: ');
    repeat
      K1 := ReadKey;
      if K1 = #27 then Halt (0);
    until K1 in ['a'..'j','A'..'J'];
    Write (K1);
    if K1 < 'a' then y := Ord (K1) - 64
                else y := Ord (k1) - 96;
    repeat
      K2 := ReadKey;
      if K2 = #27 then Halt (0);
    until K2 in ['0'..'9'];
    x := Ord (K2) - 48;
    if x = 0 then x := 10;
    WriteLn (x);
    B := True;
    if (Pole[x,y] = -2) or (Pole[x,y] = 1) then
    begin
      WriteLn ('Erroneous course...');
      B := False;
    end; {if}
  until B;
  if Pole[x,y] = 0 then
  begin
    WriteLn ('Shot down!');
    Pole[x,y] := 1;
    Res := True;
  end else
  begin
    WriteLn ('Miss.');
    Pole[x,y] := -2;
    Res := False;
  end; {if}
  Life := False;
  for x := 1 to 10 do
    for y := 1 to 10 do
      if Pole[x,y] = 0 then Life := True;
end; {func Life}
 
procedure Print;
var x, y: Integer;
begin
  WriteLn ('  1234567890');
  WriteLn (' ÚÄÄÄÄÄÄÄÄÄÄ¿');
  for y := 1 to 10 do
  begin
    Write (Char (y + 64), 'Ві');
    for x := 1 to 10 do
    begin
      case Pole[x,y] of
        -2: Write ('.');
         0: Write ('Гѕ');
         1: write ('*');
        else Write (' ');
      end; {case}
    end; {for}
    WriteLn ('Ві');
  end; {for}
  WriteLn (' ÀÄÄÄÄÄÄÄÄÄÄÙ');
end; {proc Print}
 
{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
 
var K: Char;
    GM, R: Boolean;
 
begin
  ClrScr;
  repeat
    WriteLn;
    WriteLn (' * * * Sea Battle - console version. By Akatov Aleksej, 2004 year. * * *');
    Write ('Playing (y/n)? ');
    K := ReadKey;
    if K = #27 then Halt (0);
    WriteLn (K);
    if (K = 'Y') or (K = 'y') then
    begin
      Start;
      WriteLn ('I am ready!');
      repeat
        repeat
          GM := Life (R);
        until not GM or not R;
        if GM then
        begin
          GM := not Comput;
          if not GM then
          begin
            WriteLn ('You have lost.');
            WriteLn;
            Print;
          end; {if}
        end else
        begin
          WriteLn ('You winner!');
        end; {if}
      until not GM;
    end; {if}
  until (K = 'N') or (K = 'n');
end.