svn/view/Unit1.pas

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Menus,
  System.Math, FMX.Objects, FMX.StdCtrls;

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 [0 .. Count * Count - 4] of TGridData;
    FTurnNumber: integer;
    FTurnIndex: integer;
    FActive: Boolean;
    function GetStrings(X, Y: integer): TStoneType;
    procedure SetStrings(X, Y: integer; const Value: TStoneType);
    procedure SetTurnNumber(const Value: integer);
  public
    procedure Clear;
    function CalScore(Stone: TStoneType; X, Y: integer): integer;
    function CanSetStone(Stone: TStoneType; X, Y: integer; Reverse: Boolean;
      const Visible: Boolean = false): Boolean;
    function NextStone(Stone: TStoneType): TPoint;
    procedure Start;
    procedure Restart;
    procedure Pause;
    property Strings[X, Y: integer]: TStoneType read GetStrings
      write SetStrings; default;
    property TurnNumber: integer read FTurnNumber write SetTurnNumber;
    property Active: Boolean read FActive;
  end;

  TForm1 = class(TForm)
    Timer1: TTimer;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    MenuItem5: TMenuItem;
    MenuItem6: TMenuItem;
    MenuItem7: TMenuItem;
    PaintBox1: TPaintBox;
    MenuItem8: TMenuItem;
    MenuItem9: TMenuItem;
    MenuItem10: TMenuItem;
    MenuItem11: TMenuItem;
    MenuItem12: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure MenuItem4Click(Sender: TObject);
    procedure MenuItem2Click(Sender: TObject);
    procedure PaintBox1Tap(Sender: TObject; const Point: TPointF);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
    procedure MenuItem6Click(Sender: TObject);
    procedure PaintBox1Resize(Sender: TObject);
    procedure MenuItem8Click(Sender: TObject);
    procedure MenuItem10Click(Sender: TObject);
    procedure MenuItem11Click(Sender: TObject);
  private
    { Private ���� }
    StoneGrid: TStoneGrid;
    Index: TPlayer;
    Size: integer;
    procedure CompStone;
    procedure GameStart;
    procedure ChangePlayer;
  public
    { Public ���� }
  end;

var
  Player1: TPlayer;
  Player2: TPlayer;

  Form1: TForm1;

implementation

{$R *.fmx}
{$R *.Windows.fmx MSWINDOWS}
{ TStoneGrid }

function TStoneGrid.CalScore(Stone: TStoneType; X, Y: integer): integer;
var
  i, j: integer;
begin
  if CanSetStone(Stone, X, Y, true) = true then
  begin
    if Stone = stBlack then
      Stone := stWhite
    else
      Stone := stBlack;
    result := 0;
    for i := 0 to Count - 1 do
      for j := 0 to Count - 1 do
        if CanSetStone(Stone, i, j, false) = true then
          inc(result);
    FStrings := FBuffer[FTurnIndex];
  end
  else
  begin
    FStrings := FBuffer[FTurnIndex];
    result := -1;
  end;
end;

function TStoneGrid.CanSetStone(Stone: TStoneType; X, Y: integer;
  Reverse: Boolean; const Visible: Boolean): Boolean;
var
  i, k: integer;
  p: Boolean;
  q: ^TPoint;
  list: TList;
  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 = Stone then
        if i > 1 then
        begin
          result := true;
          if Reverse = true then
          begin
            for j := 1 to i - 1 do
            begin
              New(q);
              q^ := Point(X + m * j, Y + n * j);
              list.Add(q);
            end;
            break;
          end
          else
          begin
            p := false;
            break;
          end;
        end
        else
          break
      else
        inc(i);
    end;
  end;

begin
  list := TList.Create;
  try
    result := false;
    p := true;
    if GetStrings(X, Y) = stNone 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);
    end;
    if (Reverse = true) and (result = true) then
    begin
      SetStrings(X, Y, Stone);
      for i := 0 to list.Count - 1 do
      begin
        if Visible = true then
        begin
          for k := 1 to 10 do
          begin
            Sleep(10);
            Application.ProcessMessages;
          end;
          Form1.PaintBox1.Repaint;
        end;
        q := list[i];
        SetStrings(q^.X, q^.Y, Stone);
      end;
    end;
  finally
    for i := 0 to list.Count - 1 do
      Dispose(list[i]);
    list.Free;
  end;
  if Visible = true then
  begin
    inc(FTurnIndex);
    inc(FTurnNumber);
    FBuffer[FTurnIndex] := FStrings;
  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 := 0;
  FTurnIndex := 0;
  FBuffer[0] := FStrings;
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(Stone: TStoneType): 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(Stone, 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.Pause;
begin
  FActive := false;
end;

procedure TStoneGrid.Restart;
begin
  FActive := true;
  FTurnIndex := FTurnNumber;
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;
  FActive := false;
  FStrings := FBuffer[FTurnNumber];
end;

procedure TStoneGrid.Start;
begin
  Clear;
  FActive := true;
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.Stone, i, j, false) = true then
        begin
          result := true;
          break;
        end;
      if result = true then
        break;
    end;
  end;

begin
  Main;
  if Execute = false then
  begin
    Main;
    if Execute = false then
    begin
      StoneGrid.Pause;
      Timer1.Enabled := 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) + #13#10 + '(Player2) ' +
        IntToStr(n));
    end;
  end;
end;

procedure TForm1.CompStone;
var
  s: TPoint;
begin
  s := StoneGrid.NextStone(Index.Stone);
  StoneGrid.CanSetStone(Index.Stone, s.X, s.Y, true, true);
  PaintBox1.Repaint;
  ChangePlayer;
end;

procedure TForm1.GameStart;
begin
  StoneGrid.Start;
  PaintBox1.Repaint;
  Index := Player1;
  Timer1.Enabled := true;
end;

procedure TForm1.MenuItem10Click(Sender: TObject);
begin
  StoneGrid.Restart;
  Timer1.Enabled := true;
end;

procedure TForm1.MenuItem11Click(Sender: TObject);
begin
  Timer1.Enabled := false;
  with StoneGrid do
    if Sender = MenuItem11 then
      TurnNumber := TurnNumber + 1
    else
      TurnNumber := TurnNumber - 1;
  PaintBox1.Repaint;
end;

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

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

procedure TForm1.MenuItem6Click(Sender: TObject);
begin
  Player1.Auto := MenuItem6.IsChecked;
  Player2.Auto := MenuItem7.IsChecked;
  MenuItem10Click(Sender);
end;

procedure TForm1.MenuItem8Click(Sender: TObject);
begin
  StoneGrid.Pause;
  Timer1.Enabled := false;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
var
  i, j: integer;
begin
  Canvas.Fill.Color := TAlphaColors.White;
  Canvas.FillRect(RectF(0, 0, Count * Size, Count * Size), 0, 0, [], 1);
  for i := 0 to Count do
  begin
    Canvas.DrawLine(PointF(i * Size, 0), PointF(i * Size, Size * Count), 1);
    for j := 0 to Count do
    begin
      Canvas.DrawLine(PointF(0, j * Size), PointF(Count * Size, j * Size), 1);
      case StoneGrid.Strings[i, j] of
        stWhite:
          Canvas.DrawEllipse(RectF(i * Size, j * Size, (i + 1) * Size,
            (j + 1) * Size), 1);
        stBlack:
          begin
            Canvas.Fill.Color := TAlphaColors.Black;
            Canvas.FillEllipse(RectF(i * Size, j * Size, (i + 1) * Size,
              (j + 1) * Size), 1);
          end;
      end;
    end;
  end;
end;

procedure TForm1.PaintBox1Resize(Sender: TObject);
begin
  Size := Min(ClientWidth, ClientHeight) div Count;
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;
  with PaintBox1.Canvas do
  begin
    StrokeDash := TStrokeDash.Solid;
    Stroke.Color := TAlphaColors.Black;
    StrokeThickness := 3;
  end;
  PaintBox1Resize(Sender);
  GameStart;
end;

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

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  PaintBox1Tap(Sender, PointF(X, Y));
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if (StoneGrid.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;
  PaintTo(Canvas);
end;

procedure TForm1.PaintBox1Tap(Sender: TObject; const Point: TPointF);
begin
  if Index.Auto = false then
  begin
    MenuItem10Click(Sender);
    if StoneGrid.CanSetStone(Index.Stone, Floor(Point.X / Size),
      Floor(Point.Y / Size), true, true) = true then
    begin
      PaintBox1.Repaint;
      ChangePlayer;
    end;
  end;
end;

end.