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;
  public
    property Auto: Boolean read FAuto write FAuto;
  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
    begin
        Player:=Player2;
    end else
    begin
        Player:=Player1;
    end;
        result:=0;
    for i:=0 to Count-1 do
    begin
      for j:=0 to Count-1 do
      begin
        if CanSetStone(Player,i,j,false) = true then
        begin
                inc(result);
        end;
      end;
    end;
        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, j: integer;
begin
        result:=false;
  if GetStrings(X,Y) = stNone then
  begin
    if Player = Player1 then
    begin
        i:=1;
      while true do
      begin
        case GetStrings(X-i,Y) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X-j,Y,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X-i,Y+i) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X-j,Y+j,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X,Y+i) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X,Y+j,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X+i,Y+i) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X+j,Y+j,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X+i,Y) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X+j,Y,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X+i,Y-i) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X+j,Y-j,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X,Y-i) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X,Y-j,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X-i,Y-i) of
        stBlack:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X-j,Y-j,stBlack);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        stWhite:
                inc(i);
        else
                break;
        end;
      end;
      if (Reverse = true)and(result = true) then
      begin
                SetStrings(X,Y,stBlack);
      end;
    end else
    begin
        i:=1;
      while true do
      begin
        case GetStrings(X-i,Y) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X-j,Y,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X+i,Y) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X+j,Y,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X-i,Y-i) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X-j,Y-j,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X,Y-i) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X,Y-j,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X+i,Y-i) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X+j,Y-j,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X-i,Y+i) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:=1 to i-1 do
              begin
                        SetStrings(X-j,Y+j,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X,Y+i) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:= 1 to i-1 do
              begin
                        SetStrings(X,Y+j,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
        i:=1;
      while true do
      begin
        case GetStrings(X+i,Y+i) of
        stBlack:
                inc(i);
        stWhite:
          if i > 1 then
          begin
                result:=true;
            if Reverse = true then
            begin
              for j:= 1 to i-1 do
              begin
                        SetStrings(X+j,Y+j,stWhite);
              end;
                break;
            end else
            begin
                Exit;
            end;
          end else
          begin
                break;
          end;
        else
                break;
        end;
      end;
      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
  begin
    for j:=0 to Count-1 do
    begin
        Strings[i,j]:=stNone;
    end;
  end;
        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
  begin
        result:=FStrings[X,Y];
  end else
  begin
        result:=stError;
  end;
end;

function TStoneGrid.NextStone(Player: TPlayer): TPoint;
var
  i, j, m, n: integer;
begin
        n:=-1;
  for i:=0 to Count-1 do
  begin
    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;
  end;
  if n = -1 then
  begin
        result:=Point(-1,-1);
  end;
end;

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

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

{ TForm1 }

procedure TForm1.ChangePlayer;
var
  i, j, m, n: integer;
  s: string;
  procedure Main;
  begin
    if Index = Player1 then
    begin
        Index:=Player2;
    end else
    begin
        Index:=Player1;
    end;
  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
      begin
        if StoneGrid.CanSetStone(Index,i,j,false) = true then
        begin
                result:=true;
                break;
        end;
      end;
      if result = true then
      begin
            break;
      end;
    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
      begin
        for j:=0 to Count-1 do
        begin
          case StoneGrid[i,j] of
          stBlack:
                inc(m);
          stWhite:
                inc(n);
          end;
        end;
      end;
      if m > n then
      begin
                s:='Player1 Win:'+#13#10;
      end else
        if m < n then
      begin
                s:='Player2 Win:'+#13#10;
      end else
      begin
                s:='Draw:'+#13#10;
      end;
        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
  begin
    for j:=0 to Count-1 do
    begin
      case StoneGrid.Strings[i,j] of
      stWhite:
                inc(m);
      stBlack:
                inc(n);
      end;
    end;
  end;
  if (m = 0)or(n = 0)or(m+n = Count*Count) then
  begin
    if n > m then
    begin
        s:='Player1 Win'+#13#10;
    end else
        if n < m then
    begin
        s:='Player2 Win'+#13#10;
    end else
    begin
        s:='draw'+#13#10;
    end;
        Timer1.Enabled:=false;
        Active:=false;
        Showmessage(s+'(Player1) '+IntToStr(n)+#13#10+'(Player2) '+IntToStr(m));
  end else
  begin
        ChangePlayer;
  end;
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;
        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
  begin
        Player1.Auto:=Player11.Checked;
  end else
  begin
        Player2.Auto:=Player21.Checked;
  end;
end;

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

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

end.
 