svn/view/Unit1.pas

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ExtCtrls, Math;

const
  Count = 8;

type
  TStoneType = (stNone, stWhite, stBlack, stError);

  TGridData = array [0 .. Count - 1] of array [0 .. Count - 1] of TStoneType;

  TPlayer = class
  private
    FAuto: Boolean;
    FStone: TStoneType;
  public
    property Auto: Boolean read FAuto write FAuto;
    property Stone: TStoneType read FStone write FStone;
  end;

  TStoneGrid = class
  private
    FStrings: TGridData;
    FBuffer: array [1 .. Count * Count - 4] of TGridData;
    FTurnNumber: integer;
    FTurnIndex: integer;
    function GetStrings(X, Y: integer): TStoneType;
    procedure SetStrings(X, Y: integer; const Value: TStoneType);
    procedure SetTurnNumber(const Value: integer);
  public
    procedure Clear;
    procedure BackUp;
    function CalScore(Player: TPlayer; X, Y: integer): integer;
    function CanSetStone(Player: TPlayer; X, Y: integer;
      Reverse: Boolean): Boolean;
    function NextStone(Player: TPlayer): TPoint;
    property Strings[X, Y: integer]: TStoneType read GetStrings
      write SetStrings; default;
    property TurnNumber: integer read FTurnNumber write SetTurnNumber;
  end;

  TForm1 = class(TForm)
    Timer1: TTimer;
    MainMenu1: TMainMenu;
    Game1: TMenuItem;
    Start1: TMenuItem;
    N1: TMenuItem;
    End1: TMenuItem;
    Com1: TMenuItem;
    Player11: TMenuItem;
    Player21: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: integer);
    procedure Timer1Timer(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Player(Sender: TObject);
    procedure Start1Click(Sender: TObject);
    procedure End1Click(Sender: TObject);
  private
    { Private 宣言 }
    StoneGrid: TStoneGrid;
    Index: TPlayer;
    Active: Boolean;
    Size: integer;
    procedure CompStone;
    procedure GameStart;
    procedure ChangePlayer;
    procedure CheckGame;
  public
    { Public 宣言 }
  end;

var
  Player1: TPlayer;
  Player2: TPlayer;

  Form1: TForm1;

implementation

{$R *.dfm}
{ TStoneGrid }

procedure TStoneGrid.BackUp;
begin
  FBuffer[FTurnNumber] := FStrings;
  if FTurnNumber < Count * Count - 4 then
  begin
    inc(FTurnNumber);
    FTurnIndex := FTurnNumber;
    FBuffer[FTurnNumber] := FStrings;
  end;
end;

function TStoneGrid.CalScore(Player: TPlayer; X, Y: integer): integer;
var
  i, j: integer;
begin
  if CanSetStone(Player, X, Y, true) = true then
  begin
    if Player = Player1 then
      Player := Player2
    else
      Player := Player1;
    result := 0;
    for i := 0 to Count - 1 do
      for j := 0 to Count - 1 do
        if CanSetStone(Player, i, j, false) = true then
          inc(result);
    FStrings := FBuffer[FTurnNumber];
  end
  else
  begin
    FStrings := FBuffer[FTurnNumber];
    result := -1;
  end;
end;

function TStoneGrid.CanSetStone(Player: TPlayer; X, Y: integer;
  Reverse: Boolean): Boolean;
var
  i: integer;
  p: Boolean;
  procedure Method(m, n: integer);
  var
    s: TStoneType;
    j: integer;
  begin
    if p = false then
      Exit;
    i := 1;
    while true do
    begin
      s := GetStrings(X + m * i, Y + n * i);
      if (s = stNone) or (s = stError) then
        break
      else if s = Player.Stone then
        if i > 1 then
        begin
          result := true;
          if Reverse = true then
          begin
            for j := 1 to i - 1 do
              SetStrings(X + m * j, Y + n * j, Player.Stone);
            break;
          end
          else
          begin
            p := false;
            break;
          end;
        end
        else
          break
      else
        inc(i);
    end;
  end;

begin
  result := false;
  if GetStrings(X, Y) = stNone then
  begin
    p := true;
    if Player.Stone = stBlack then
    begin
      Method(-1, -1);
      Method(-1, 0);
      Method(-1, 1);
      Method(0, -1);
      Method(0, 1);
      Method(1, -1);
      Method(1, 0);
      Method(1, 1);
      if (Reverse = true) and (result = true) then
      begin
        SetStrings(X, Y, stBlack);
      end;
    end
    else
    begin
      Method(-1, -1);
      Method(-1, 0);
      Method(-1, 1);
      Method(0, -1);
      Method(0, 1);
      Method(1, -1);
      Method(1, 0);
      Method(1, 1);
      if (Reverse = true) and (result = true) then
      begin
        Strings[X, Y] := stWhite;
      end;
    end;
  end;
end;

procedure TStoneGrid.Clear;
var
  i, j: integer;
begin
  for i := 0 to Count - 1 do
    for j := 0 to Count - 1 do
      Strings[i, j] := stNone;
  Strings[3, 3] := stBlack;
  Strings[4, 4] := stBlack;
  Strings[4, 3] := stWhite;
  Strings[3, 4] := stWhite;
  FTurnNumber := 1;
  FTurnIndex := 1;
end;

function TStoneGrid.GetStrings(X, Y: integer): TStoneType;
begin
  if (X >= 0) and (X < Count) and (Y >= 0) and (Y < Count) then
    result := FStrings[X, Y]
  else
    result := stError;
end;

function TStoneGrid.NextStone(Player: TPlayer): TPoint;
var
  i, j, m, n: integer;
begin
  n := -1;
  for i := 0 to Count - 1 do
    for j := 0 to Count - 1 do
    begin
      m := CalScore(Player, i, j);
      if (n = -1) or ((m > -1) and (n > m)) then
      begin
        n := m;
        result := Point(i, j);
      end;
    end;
  if n = -1 then
    result := Point(-1, -1);
end;

procedure TStoneGrid.SetStrings(X, Y: integer; const Value: TStoneType);
begin
  if (X >= 0) and (X < Count) and (Y >= 0) and (Y < Count) then
    FStrings[X, Y] := Value;
end;

procedure TStoneGrid.SetTurnNumber(const Value: integer);
begin
  if Value > FTurnIndex then
    FTurnNumber := FTurnIndex
  else
    FTurnNumber := Value;
  FStrings := FBuffer[FTurnNumber];
end;

{ TForm1 }

procedure TForm1.ChangePlayer;
var
  i, j, m, n: integer;
  s: string;
  procedure Main;
  begin
    if Index = Player1 then
      Index := Player2
    else
      Index := Player1;
  end;
  function Execute: Boolean;
  var
    i, j: integer;
  begin
    result := false;
    for i := 0 to Count - 1 do
    begin
      for j := 0 to Count - 1 do
        if StoneGrid.CanSetStone(Index, i, j, false) = true then
        begin
          result := true;
          break;
        end;
      if result = true then
        break;
    end;
  end;

begin
  StoneGrid.BackUp;
  Main;
  if Execute = false then
  begin
    Main;
    if Execute = false then
    begin
      Timer1.Enabled := false;
      Active := false;
      m := 0;
      n := 0;
      for i := 0 to Count - 1 do
        for j := 0 to Count - 1 do
          case StoneGrid[i, j] of
            stBlack:
              inc(m);
            stWhite:
              inc(n);
          end;
      if m > n then
        s := 'Player1 Win:' + #13#10
      else if m < n then
        s := 'Player2 Win:' + #13#10
      else
        s := 'Draw:' + #13#10;
      Showmessage(s + '(Player1) ' + IntToStr(m) + '(Player2) ' + IntToStr(n));
    end;
  end;
end;

procedure TForm1.CheckGame;
var
  i, j, m, n: integer;
  s: string;
begin
  m := 0;
  n := 0;
  for i := 0 to Count - 1 do
    for j := 0 to Count - 1 do
      case StoneGrid.Strings[i, j] of
        stWhite:
          inc(m);
        stBlack:
          inc(n);
      end;
  if (m = 0) or (n = 0) or (m + n = Count * Count) then
  begin
    if n > m then
      s := 'Player1 Win' + #13#10
    else if n < m then
      s := 'Player2 Win' + #13#10
    else
      s := 'draw' + #13#10;
    Timer1.Enabled := false;
    Active := false;
    Showmessage(s + '(Player1) ' + IntToStr(n) + #13#10 + '(Player2) ' +
      IntToStr(m));
  end
  else
    ChangePlayer;
end;

procedure TForm1.CompStone;
var
  s: TPoint;
begin
  s := StoneGrid.NextStone(Index);
  StoneGrid.CanSetStone(Index, s.X, s.Y, true);
  FormPaint(nil);
  CheckGame;
end;

procedure TForm1.GameStart;
begin
  StoneGrid.Clear;
  StoneGrid.BackUp;
  FormPaint(nil);
  Index := Player1;
  Active := true;
  Timer1.Enabled := true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  StoneGrid := TStoneGrid.Create;
  Player1 := TPlayer.Create;
  Player2 := TPlayer.Create;
  Player1.Stone := stBlack;
  Player2.Stone := stWhite;
  Player2.Auto := true;
  GameStart;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  StoneGrid.Free;
  Player1.Free;
  Player2.Free;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  i, j: integer;
begin
  Canvas.Brush.Color := clWhite;
  Canvas.Rectangle(0, 0, Count * Size, Count * Size);
  for i := 0 to Count - 1 do
  begin
    Canvas.MoveTo(i * Size, 0);
    Canvas.LineTo(i * Size, Size * Count);
    for j := 0 to Count - 1 do
    begin
      Canvas.MoveTo(0, j * Size);
      Canvas.LineTo(Count * Size, j * Size);
      case StoneGrid.Strings[i, j] of
        stWhite:
          begin
            Canvas.Brush.Color := clWhite;
            Canvas.Ellipse(i * Size, j * Size, (i + 1) * Size, (j + 1) * Size);
          end;
        stBlack:
          begin
            Canvas.Brush.Color := clBlack;
            Canvas.Ellipse(i * Size, j * Size, (i + 1) * Size, (j + 1) * Size);
          end;
      end;
    end;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: integer);
begin
  if (Active = true) and (Index.Auto = false) and (X <= Count * Size) and
    (Y <= Count * Size) then
  begin
    X := X div Size;
    Y := Y div Size;
    if StoneGrid.CanSetStone(Index, X, Y, true) = true then
    begin
      FormPaint(Sender);
      CheckGame;
    end;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if (Active = true) and (Index.Auto = true) then
  begin
    Timer1.Enabled := false;
    CompStone;
    Timer1.Enabled := true;
  end;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Size := Min(ClientWidth, ClientHeight) div Count;
  FormPaint(Sender);
end;

procedure TForm1.Player(Sender: TObject);
begin
  (Sender as TMenuItem).Checked := not(Sender as TMenuItem).Checked;
  if Sender = Player11 then
    Player1.Auto := Player11.Checked
  else
    Player2.Auto := Player21.Checked;
end;

procedure TForm1.Start1Click(Sender: TObject);
begin
  GameStart;
end;

procedure TForm1.End1Click(Sender: TObject);
begin
  Close;
end;

end.