svn/view/Unit1.pas

unit Unit1;

interface

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

const
  bmp_count = 8;

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

  TEffectData = record
    X, Y: integer;
    Left, Top: integer;
  end;

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

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

  TStoneGrid = class(TObject)
  private
    FStrings: TGridData;
    FBuffer: array [0 .. bmp_count * bmp_count - 4] of TGridData;
    FTurnNumber: integer;
    FTurnIndex: integer;
    FActive: Boolean;
    FList: TList<TEffectData>;
    FEffectStone: TStoneType;
    FIndex_X: integer;
    FIndex_Y: integer;
    FGameOver: Boolean;
    function GetStrings(X, Y: integer): TStoneType;
    procedure SetStrings(X, Y: integer; const Value: TStoneType);
    procedure SetTurnNumber(const Value: integer);
    function GetActive: Boolean;
    procedure SetActive(const Value: Boolean);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function CalScore(Stone: TStoneType; X, Y: integer;
      out Score: integer): Boolean;
    function CanSetStone(Stone: TStoneType; X, Y: integer; Reverse: Boolean;
      const Visible: Boolean = false): Boolean;
    function NextStone(Stone: TStoneType; var Pos: TPoint): Boolean;
    procedure Start;
    procedure Restart;
    procedure Pause;
    function ListExecute: Boolean;
    procedure GameOver;
    procedure Paint(Canvas: TCanvas);
    procedure ImageCount(X, Y: integer);
    function AddScore(X, Y: integer; const NG: array of TPoint): integer;
    property Strings[X, Y: integer]: TStoneType read GetStrings
      write SetStrings; default;
    property TurnNumber: integer read FTurnNumber write SetTurnNumber;
    property Active: Boolean read GetActive write SetActive;
  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;
    Timer2: TTimer;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    MenuItem13: TMenuItem;
    MenuItem14: TMenuItem;
    MenuItem15: 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);
    procedure Timer2Timer(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}
{$R *.XLgXhdpiTb.fmx ANDROID}
{ TStoneGrid }

function TStoneGrid.AddScore(X, Y: integer; const NG: array of TPoint): integer;
var
  s: TPoint;
begin
  result := 0;
  for s in NG do
    if (X = s.X) and (Y = s.Y) then
    begin
      result := 10;
      break;
    end;
end;

function TStoneGrid.CalScore(Stone: TStoneType; X, Y: integer;
  out Score: integer): Boolean;
var
  i, j: integer;
  loop: integer;
const
  waste: array [1 .. 12] of TPoint = ((X: 1; Y: 0), (X: 6; Y: 0), (X: 0; Y: 1),
    (X: 1; Y: 1), (X: 6; Y: 1), (X: 7; Y: 1), (X: 0; Y: 6), (X: 1; Y: 6), (X: 6;
    Y: 6), (X: 7; Y: 6), (X: 1; Y: 7), (X: 6; Y: 7));
  worth: array [1 .. 4] of TPoint = ((X: 0; Y: 0), (X: 7; Y: 0), (X: 0; Y: 7),
    (X: 7; Y: 7));
label Last;
  procedure Easy;
  var
    m, n: integer;
  begin
    for m := 0 to bmp_count - 1 do
      for n := 0 to bmp_count - 1 do
        if CanSetStone(Stone, m, n, false) = true then
        begin
          inc(Score);
          inc(Score, AddScore(m, n, worth));
        end;
  end;
  procedure Hard;
  var
    m, n: integer;
  begin
    if loop > 1 then
      Exit;
    inc(loop);
    for m := 0 to bmp_count - 1 do
      for n := 0 to bmp_count - 1 do
      begin
        if CanSetStone(Stone, m, n, true) = true then
        begin
          if (loop mod 2) > 0 then
          begin
            inc(Score, AddScore(m, n, worth));
            if FTurnIndex + loop < 50 then
              dec(Score, AddScore(m, n, waste));
          end
          else
          begin
            dec(Score, AddScore(m, n, worth));
            if FTurnIndex + loop < 50 then
              inc(Score, AddScore(m, n, waste));
          end;
          case Stone of
            stBlack:
              Stone := stWhite;
            stWhite:
              Stone := stBlack;
          end;
          Hard;
          if loop > 1 then
          begin
            Easy;
            FStrings := FBuffer[FTurnIndex + loop];
          end else
            FBuffer[FTurnIndex + loop] := FStrings;
        end;
      end;
    dec(loop);
  end;

begin
  if CanSetStone(Stone, X, Y, true) = true then
  begin
    Score := 0;
    result := true;
    if FTurnIndex < 50 then
      inc(Score, AddScore(X, Y, waste));
    dec(Score, AddScore(X, Y, worth));
    case Stone of
      stBlack:
        Stone := stWhite;
      stWhite:
        Stone := stBlack;
    end;
    if (Form1.MenuItem14.IsChecked = true) and (FTurnIndex + 2 <= 60) then
    begin
      loop := 0;
      Hard;
    end
    else
      Easy;
  end
  else
    result := false;
  FStrings := FBuffer[FTurnIndex];
end;

function TStoneGrid.CanSetStone(Stone: TStoneType; X, Y: integer;
  Reverse: Boolean; const Visible: Boolean): Boolean;
var
  i: integer;
  p: Boolean;
  q: TEffectData;
  procedure Method(m, n: integer);
  var
    s: TStoneType;
    j: integer;
    k: integer;
  begin
    if p = false then
      Exit;
    i := 1;
    while true do
    begin
      s := GetStrings(X + m * i, Y + n * i);
      if s = stEffect then
        s := FEffectStone;
      if (s = stNone) or (s = stError) then
        break
      else if s = Stone then
        if i > 1 then
        begin
          if (result = false) and (Reverse = true) then
            SetStrings(X, Y, Stone);
          result := true;
          if Reverse = true then
          begin
            Form1.PaintBox1.Repaint;
            for j := 1 to i - 1 do
            begin
              if Visible = true then
              begin
                FEffectStone := Stone;
                q.Left := X + m * j;
                q.Top := Y + n * j;
                q.X := 0;
                q.Y := 0;
                FList.Add(q);
                SetStrings(q.Left, q.Top, stEffect);
                for k := 1 to 10 do
                begin
                  Sleep(15);
                  Application.ProcessMessages;
                end;
              end
              else
                SetStrings(X + m * j, Y + n * j, Stone);
            end;
            break;
          end
          else
          begin
            p := false;
            break;
          end;
        end
        else
          break
      else
        inc(i);
    end;
  end;

begin
  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;
end;

procedure TStoneGrid.Clear;
var
  i, j: integer;
begin
  FList.Clear;
  for i := 0 to bmp_count - 1 do
    for j := 0 to bmp_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;

constructor TStoneGrid.Create;
begin
  inherited;
  FList := TList<TEffectData>.Create;
end;

destructor TStoneGrid.Destroy;
begin
  FList.Free;
  inherited;
end;

procedure TStoneGrid.GameOver;
begin
  FGameOver := true;
  FActive := false;
end;

function TStoneGrid.GetActive: Boolean;
begin
  if (FActive = true) and (FList.Count = 0) then
    result := true
  else
    result := false;
end;

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

procedure TStoneGrid.ImageCount(X, Y: integer);
begin
  FIndex_X := X;
  FIndex_Y := Y;
end;

function TStoneGrid.ListExecute: Boolean;
var
  i: integer;
  s: TEffectData;
begin
  if FList.Count = 0 then
    result := false
  else
  begin
    i := 0;
    while i < FList.Count do
    begin
      s := FList[i];
      if s.X < FIndex_X - 1 then
        s.X := s.X + 1
      else if s.Y < FIndex_Y - 1 then
      begin
        s.X := 0;
        s.Y := s.Y + 1;
      end
      else
      begin
        SetStrings(s.Left, s.Top, FEffectStone);
        FList.Delete(i);
        inc(i);
        continue;
      end;
      FList[i] := s;
      inc(i);
    end;
    if FList.Count = 0 then
    begin
      inc(FTurnIndex);
      inc(FTurnNumber);
      FBuffer[FTurnIndex] := FStrings;
      Form1.PaintBox1.Repaint;
      Form1.ChangePlayer;
      if FGameOver = false then
        FActive := true
    end;
    result := true;
  end;
end;

function TStoneGrid.NextStone(Stone: TStoneType; var Pos: TPoint): Boolean;
var
  i, j, m, n: integer;
begin
  result := false;
  n := 0;
  for i := 0 to bmp_count - 1 do
    for j := 0 to bmp_count - 1 do
      if (CalScore(Stone, i, j, m) = true) and ((result = false) or (m < n))
      then
      begin
        if result = false then
          result := true;
        n := m;
        Pos := Point(i, j);
      end;
end;

procedure TStoneGrid.Paint(Canvas: TCanvas);
var
  k: integer;
  s: TBitmap;
  p: TEffectData;
begin
  k := Form1.Size;
  if FEffectStone = stBlack then
    s := Form1.Image1.Bitmap
  else
    s := Form1.Image2.Bitmap;
  for p in FList do
  begin
    Canvas.DrawBitmap(s, RectF(p.X * 50, p.Y * 50, (p.X + 1) * 50,
      (p.Y + 1) * 50), RectF(p.Left * k, p.Top * k, (p.Left + 1) * k,
      (p.Top + 1) * k), 1);
  end;
end;

procedure TStoneGrid.Pause;
begin
  FActive := false;
end;

procedure TStoneGrid.Restart;
begin
  FActive := true;
  FGameOver := false;
  FTurnIndex := FTurnNumber;
end;

procedure TStoneGrid.SetActive(const Value: Boolean);
begin
  if (FGameOver = false) or (Value = false) then
    FActive := Value;
end;

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

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

procedure TStoneGrid.Start;
begin
  Clear;
  FActive := true;
  FGameOver := false;
end;

{ TForm1 }

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

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

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

procedure TForm1.GameStart;
begin
  Index := Player1;
  StoneGrid.Start;
  PaintBox1.Repaint;
  Caption := '�������n������';
end;

procedure TForm1.MenuItem10Click(Sender: TObject);
begin
  StoneGrid.Restart;
end;

procedure TForm1.MenuItem11Click(Sender: TObject);
var
  i: integer;
begin
  with StoneGrid do
  begin
    i := TurnNumber;
    if Sender = MenuItem11 then
      TurnNumber := TurnNumber + 1
    else
      TurnNumber := TurnNumber - 1;
    if (i = TurnNumber) then
      Exit
    else
      Pause;
  end;
  PaintBox1.Repaint;
  ChangePlayer;
end;

procedure TForm1.MenuItem2Click(Sender: TObject);
begin
  Timer1.Enabled := false;
  Timer2.Enabled := false;
  GameStart;
  Timer1.Enabled := true;
  Timer2.Enabled := true;
end;

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

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

procedure TForm1.MenuItem8Click(Sender: TObject);
begin
  StoneGrid.Pause;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
var
  i, j: integer;
begin
  if StoneGrid.Active = false then
    StoneGrid.Paint(Canvas);
  for i := 0 to bmp_count - 1 do
  begin
    for j := 0 to bmp_count - 1 do
    begin
      case StoneGrid.Strings[i, j] of
        stWhite:
          Canvas.DrawBitmap(Image3.Bitmap, RectF(100, 0, 150, 50),
            RectF(i * Size, j * Size, (i + 1) * Size, (j + 1) * Size), 1);
        stBlack:
          Canvas.DrawBitmap(Image3.Bitmap, RectF(50, 0, 100, 50),
            RectF(i * Size, j * Size, (i + 1) * Size, (j + 1) * Size), 1);
        stEffect:
          continue;
      else
        Canvas.DrawBitmap(Image3.Bitmap, RectF(0, 0, 50, 50),
          RectF(i * Size, j * Size, (i + 1) * Size, (j + 1) * Size), 1);
      end;
      Canvas.DrawLine(PointF(0, j * Size), PointF(bmp_count * Size,
        j * Size), 1);
    end;
    Canvas.DrawLine(PointF(i * Size, 0), PointF(i * Size, Size * bmp_count), 1);
  end;
  Canvas.DrawLine(PointF(bmp_count * Size, 0), PointF(bmp_count * Size,
    bmp_count * Size), 1);
  Canvas.DrawLine(PointF(0, bmp_count * Size), PointF(bmp_count * Size,
    bmp_count * Size), 1);
end;

procedure TForm1.PaintBox1Resize(Sender: TObject);
begin
  Size := Min(ClientWidth, ClientHeight) div bmp_count;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ClientWidth := 400;
  ClientHeight := 400;
  StoneGrid := TStoneGrid.Create;
  StoneGrid.ImageCount(6, 5);
  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
    CompStone;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
  if (StoneGrid.Active = false) and (StoneGrid.ListExecute = true) then
    PaintBox1.Repaint;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Size := Min(ClientWidth, ClientHeight) div bmp_count;
  PaintTo(Canvas);
end;

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

end.