リバーシ ゲームの作成(WindowsとAndroidで動作) ～Delphiソースコード集

• ホーム
• Delphiでお手軽プログラミング
• リバーシ ゲームの作成(WindowsとAndroidで動作) ～Delphiソースコード集

リバーシ ゲームの作成(WindowsとAndroidで動作) ～Delphiソースコード集

Delphiを起動してプロジェクトを作成し、オブジェクトを配置し、プロパティを設定する。

プログラミング

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.StdCtrls,
  FMX.Objects, FMX.Controls.Presentation, FMX.ScrollBox, FMX.Memo, FMX.Layouts;

type
  TForm1 = class( TForm)
    ScaledLayout1: TScaledLayout;
    Layout1: TLayout;
    Memo1: TMemo;
    Image1: TImage;
    Button1: TButton;
    Button2: TButton;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure Button2Click(Sender: TObject);
  private
    { private 宣言 }
    com_iro:Integer; //PCの色 1:白,2:黒
    user_iro:Integer;//ユーザーの色 1:白,2:黒
    //PCの順番1、ユーザーの順番2
    OrderPcUser:integer;
    //盤の状態を保持する 0まだおかれてない、１白、２黒
    fBoard:array[0..7] of array[0..7] of Integer;
    //PCの番の時に呼ぶ関数
    procedure PcCalculate();
    //配列fBoardに基づき、絵を描く
    procedure DrawBoard();
    //順番を入れ替える（ラベルにも表示する）
    procedure OrderChange();
    //開始(初期化処理)
    procedure GameStart();
    //指定したx,y座標に色(iro=1:白,2:黒)が置けるか
    //裏返す方向はdx,dyで指定する
    //置けるならTrue、置けないならFalseを返す
    function CanPutPiece(x,y, OkuIro, dx,dy: integer): boolean;
    //全ての方向に対してCanPutPieceを呼び出す
    function CanPutPieces(x,y, iro:integer):boolean;
    //指定したx,y座標に色(iro=1:白,2:黒)が置けるなら裏返す
    //置けるならTrue、置けないならFalseを返す
    function ReversePiece(x, y, iro,dx,dy: integer): Boolean;
    //全ての方向に対してReversePieceを呼び出す
    function ReversePieces(x, y, iro: integer): Boolean;
    //全て駒を置いた、又はもう駒を置けないか確認する
    //未だ駒を置ける場合はFalse、置けない場合はTrueを返す
    function CheckPieces():boolean;
    //PCとユーザーの駒の数を集計して表示する
    function PieceCount():boolean;
    //ユーザーの置ける場所が無いか確認する。無ければTrue
    function Cannot_UserPutPiece():boolean;
    //コンピューターの置ける場所が無いか確認する。無ければTrue
    function Cannot_ComPutPiece: boolean;

  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

  //PCの手
  ai:array[0..63] of TPoint = (
    (X:0;Y:0),(X:0;Y:7),(X:7;Y:7),(X:7;Y:0),
    (X:2;Y:2),(X:2;Y:5),(X:5;Y:5),(X:5;Y:2),
    (X:2;Y:0),(X:0;Y:2),(X:0;Y:5),(X:2;Y:7),
    (X:5;Y:7),(X:7;Y:5),(X:7;Y:2),(X:5;Y:0),
    (X:3;Y:1),(X:1;Y:3),(X:1;Y:4),(X:3;Y:6),
    (X:4;Y:6),(X:6;Y:4),(X:6;Y:3),(X:4;Y:1),
    (X:3;Y:0),(X:0;Y:3),(X:0;Y:4),(X:3;Y:7),
    (X:4;Y:7),(X:7;Y:4),(X:7;Y:3),(X:4;Y:0),
    (X:3;Y:2),(X:2;Y:3),(X:2;Y:4),(X:3;Y:5),
    (X:4;Y:5),(X:5;Y:4),(X:5;Y:3),(X:4;Y:2),
    (X:2;Y:1),(X:1;Y:2),(X:1;Y:5),(X:2;Y:6),
    (X:5;Y:6),(X:6;Y:5),(X:6;Y:2),(X:5;Y:1),
    (X:1;Y:0),(X:0;Y:1),(X:0;Y:6),(X:1;Y:7),
    (X:6;Y:7),(X:7;Y:6),(X:7;Y:1),(X:6;Y:0),
    (X:1;Y:1),(X:1;Y:6),(X:6;Y:6),(X:6;Y:1),
    (X:3;Y:3),(X:3;Y:4),(X:4;Y:4),(X:4;Y:3)
  );

implementation

{$R *.fmx}

{ TForm1 }

procedure TForm1.PcCalculate;
var i: Integer;
    dx,dy:integer;
begin
  if OrderPcUser=2 then exit;
  dx:=-1;
  dy:=-1;
  //ai.x,ai.y座標の順に、そこにこまが置けるか調べる
  for i := 0 to 63 do
  begin
    if fBoard[ai[i].X,ai[i].Y]=0 then
    begin
      if CanPutPieces(ai[i].X,ai[i].Y,com_iro) then
      begin
        //こまが置けるのでその座標を変数に保持する
        dx:=ai[i].X;
        dy:=ai[i].Y;
        break;
      end;
    end;
  end;
  if dx=-1 then
  begin
    //こまが置けないのでパスする
    Memo1.Lines.Add('ＰＣ：駒を置く場所が無いのでパス');
    Memo1.GoToTextEnd;
  end
  else
  begin
    //こまが置けるのでこまを置く
    fBoard[dx,dy]:=com_iro;
    //裏返す
    ReversePieces(dx,dy,com_iro);
  end;
  OrderChange();
end;

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

procedure TForm1.Button2Click(Sender: TObject);
begin
  if OrderPcUser=2 then
    if Cannot_UserPutPiece() then
      OrderChange();
end;

function TForm1.Cannot_ComPutPiece: boolean;
var x,y:integer;
    flag:boolean;
begin
  flag:=false;
  for x := 0 to 7 do
    for y := 0 to 7 do
    begin
      if fBoard[x,y]=0 then
      begin
        if CanPutPieces(x,y,com_iro) then
          flag:=true;
      end;
    end;
  result:=not flag;
end;

procedure TForm1.DrawBoard;
var x,y:integer;
begin
  Image1.Bitmap.Canvas.BeginScene();

  Image1.Bitmap.Canvas.Fill.Color:=TAlphaColorRec.Green;
  Image1.Bitmap.Canvas.Fill.Kind:=TBrushKind.Solid;
  Image1.Bitmap.Canvas.FillRect(
    RectF(0,0,Image1.Bitmap.Width,Image1.Bitmap.Height),
    0,0,[],1
  );

  Image1.Bitmap.Canvas.Stroke.Color:=TAlphaColorRec.White;
  Image1.Bitmap.Canvas.Stroke.Thickness:=6;
  Image1.Bitmap.Canvas.Stroke.Kind:=TBrushKind.Solid;

  for x := 0 to 8 do
  begin
    Image1.Bitmap.Canvas.DrawLine(
      PointF(x*80,0),PointF(x*80,640),1);
  end;
  for y := 0 to 8 do
  begin
    Image1.Bitmap.Canvas.DrawLine(
      PointF(0,y*80),PointF(640,y*80),1);
  end;

  //駒の色を描画する
  for x := 0 to 7 do
  begin
    for y := 0 to 7 do
    begin
      if fBoard[x,y]=1 then
      begin
        Image1.Bitmap.Canvas.Fill.Color:=TAlphaColorRec.White;
        Image1.Bitmap.Canvas.Fill.Kind:=TBrushKind.Solid;
        Image1.Bitmap.Canvas.Stroke.Color:=TAlphaColorRec.Black;
        Image1.Bitmap.Canvas.Stroke.Thickness:=2;
        Image1.Bitmap.Canvas.Stroke.Kind:=TBrushKind.Solid;

        //楕円塗りつぶし
        Image1.Bitmap.Canvas.FillEllipse(
          RectF(x*80+10,y*80+10,x*80+60,y*80+60),1);

        //楕円境界線描画
        Image1.Bitmap.Canvas.DrawEllipse(
          RectF(x*80+10,y*80+10,x*80+60,y*80+60),1);

      end;
      if fBoard[x,y]=2 then
      begin
        Image1.Bitmap.Canvas.Fill.Color:=TAlphaColorRec.Black;
        Image1.Bitmap.Canvas.Fill.Kind:=TBrushKind.Solid;
        Image1.Bitmap.Canvas.Stroke.Color:=TAlphaColorRec.White;
        Image1.Bitmap.Canvas.Stroke.Thickness:=2;
        Image1.Bitmap.Canvas.Stroke.Kind:=TBrushKind.Solid;

        //楕円塗りつぶし
        Image1.Bitmap.Canvas.FillEllipse(
          RectF(x*80+10,y*80+10,x*80+60,y*80+60),1);

        //楕円境界線描画
        Image1.Bitmap.Canvas.DrawEllipse(
          RectF(x*80+10,y*80+10,x*80+60,y*80+60),1);
      end;
    end;
  end;
  Image1.Bitmap.Canvas.EndScene;
  PieceCount();
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Timer1.Enabled:=False;
  Image1.Bitmap.Width:=640;
  Image1.Bitmap.Height:=640;
  Randomize;
  OrderPcUser:=0;
  GameStart();
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
var bx,by,ww:integer;
begin
  ww:=trunc(Image1.Width);
  if Image1.Width>Image1.Height then
  begin
    ww:=trunc(Image1.Height);
  end;
  if OrderPcUser=2 then
  begin
    bx:= trunc(x)*8 div ww;
    by:= trunc(y)*8 div ww;
    if (fBoard[bx,by]=0) and (CanPutPieces(bx,by,user_iro)) then
    begin
      fBoard[bx,by]:=user_iro;
      ReversePieces(bx,by,user_iro);
      OrderChange();
    end
    else
    begin
      Memo1.Lines.Add('指定した場所には置けません');
      Memo1.GoToTextEnd;
    end;
  end;
end;


function TForm1.CheckPieces: boolean;
//全て駒を置いた、又はもう駒を置けないか確認する
//未だ駒を置ける場合はFalse、置けない場合はTrueを返す
var flag:boolean;
    x,y:integer;
begin
  flag:=True;
  for x := 0 to 7 do
    for y := 0 to 7 do
      if fBoard[x,y]=0 then flag:=False;
  //盤面が空いていて白も黒も置けない場合が無いかチェック
  if flag=False then
  begin
    if Cannot_UserPutPiece and Cannot_ComPutPiece then
      flag:=True;
  end;
  Result:= flag;
end;

function TForm1.PieceCount: boolean;
//PCとユーザーの駒の数を集計して表示する
var x,y:integer;
    pc,user:integer;
begin
  pc:=0;
  user:=0;
  for x := 0 to 7 do
    for y := 0 to 7 do
    begin
      if fBoard[x,y]=user_iro then
        inc(user)
      else if fBoard[x,y]= com_iro then
        inc(pc);
    end;
  Memo1.Lines.Add('あなた：'+inttostr(user)+'個　ＰＣ：'+inttostr(pc)+'個');
  if CheckPieces then
  begin
    Memo1.Lines.Add('ゲーム終了');
    OrderPcUser:=0;
  end;
  Memo1.GoToTextEnd;
  Result:=True;
end;

function TForm1.CanPutPiece(x, y, OkuIro, dx, dy: integer): boolean;
//指定したx,y座標に色(iro=1:白,2:黒)が置けるか
//裏返す方向はdx,dyのみチェックし、置けるならTrue、置けないならFalseを返す
var KaesuIro:Integer;//裏返す対象の色
    Flag:Integer;
    SearchPoint:TPoint;//探索座標
begin
  Result:=False;
  //裏返す対象の色を設定
  KaesuIro:=1;
  if OkuIro=1 then KaesuIro:=2;
  Flag:=0;
  SearchPoint.X:=x+dx;
  SearchPoint.Y:=y+dy;
  while (SearchPoint.X>=0) and (SearchPoint.X<=7) and
        (SearchPoint.Y>=0) and (SearchPoint.Y<=7) do
  begin
    //駒が無かったら終了
    if fBoard[SearchPoint.X,SearchPoint.Y]=0 then Break
    else if fBoard[SearchPoint.X,SearchPoint.Y]=KaesuIro then
       Flag:=1 //ひっくり返す色だった場合はflagを1にする
    else if fBoard[SearchPoint.X,SearchPoint.Y]=OkuIro then
    begin
      //ひっくり返す色が間にあったのでflagを2にする
      if Flag=1 then Flag:=2;
      Break;
    end;
    SearchPoint.X:=SearchPoint.X+dx;
    SearchPoint.Y:=SearchPoint.Y+dy;
  end;
  //駒を置いてひっくり返すことが出来るのでTrueを返す
  if Flag=2 then
  begin
    Result:=True;
  end;
end;

function TForm1.CanPutPieces(x, y, iro: Integer): Boolean;
var Flag:Boolean;
begin
  Flag:=false;
  if CanPutPiece(x,y,iro, 0,-1) then Flag:=True;
  if CanPutPiece(x,y,iro,-1,-1) then Flag:=True;
  if CanPutPiece(x,y,iro,-1, 0) then Flag:=True;
  if CanPutPiece(x,y,iro,-1, 1) then Flag:=True;
  if CanPutPiece(x,y,iro, 0, 1) then Flag:=True;
  if CanPutPiece(x,y,iro, 1, 1) then Flag:=True;
  if CanPutPiece(x,y,iro, 1, 0) then Flag:=True;
  if CanPutPiece(x,y,iro, 1,-1) then Flag:=True;
  Result:=Flag;
end;


function TForm1.ReversePiece(x, y, iro, dx, dy: integer): Boolean;
//指定したx,y座標におければ裏返す。
//置く駒の色(iro)は１白、２黒、指定した方向(dx,dy)を確認する
//置けるならTrue、置けないならFalseを返す
var SearchPoint:TPoint;
begin
  Result:=CanPutPiece(x,y,iro,dx,dy);
  //裏返る場合
  if Result then
  begin
    SearchPoint.X:=x+dx;
    SearchPoint.Y:=y+dy;
    while fBoard[SearchPoint.X,SearchPoint.Y]<>iro do
    begin
      fBoard[SearchPoint.X,SearchPoint.Y]:=iro;
      SearchPoint.X:=SearchPoint.X+dx;
      SearchPoint.Y:=SearchPoint.Y+dy;
    end;
  end;
end;

function TForm1.ReversePieces(x, y, iro: integer): boolean;
var flag:Boolean;
begin
  flag:=False;
  if ReversePiece(x,y,iro, 0,-1) then flag:=True;
  if ReversePiece(x,y,iro,-1,-1) then flag:=True;
  if ReversePiece(x,y,iro,-1, 0) then flag:=True;
  if ReversePiece(x,y,iro,-1, 1) then flag:=True;
  if ReversePiece(x,y,iro, 0, 1) then flag:=True;
  if ReversePiece(x,y,iro, 1, 1) then flag:=True;
  if ReversePiece(x,y,iro, 1, 0) then flag:=True;
  if ReversePiece(x,y,iro, 1,-1) then flag:=True;
  DrawBoard();
  result:=flag;
end;


procedure TForm1.OrderChange;
begin
  if OrderPcUser=1 then OrderPcUser:=2
  else if OrderPcUser=2 then OrderPcUser:=1;
  if OrderPcUser=1 then Memo1.Lines.Add('ＰＣの番');
  if OrderPcUser=2 then Memo1.Lines.Add('あなたの番');
  Memo1.GoToTextEnd;
  if OrderPcUser=1 then Timer1.Enabled:=True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled:=False;
  PcCalculate();
end;

procedure TForm1.GameStart;
//開始(初期化処理)
var x,y:integer;
begin
  Memo1.Lines.Clear;
  for x := 0 to 7 do
    for y := 0 to 7 do
      fBoard[x,y]:=0;

  //リバーシの最初の置き方
  fBoard[3,3]:=1;
  fBoard[4,4]:=2;
  fBoard[3,4]:=2;
  fBoard[4,3]:=1;

  OrderPcUser:=Random(2)+1;

  user_iro:=Random(2)+1;
  if user_iro=1 then com_iro:=2
  else com_iro:=1;

  DrawBoard();

  if user_iro=1 then
    Memo1.Lines.Add('あなたの色：白')
  else
    Memo1.Lines.Add('あなたの色：黒');

  if OrderPcUser=1 then
    Memo1.Lines.Add('ＰＣの番')
  else
    Memo1.Lines.Add('あなたの番');

  Memo1.GoToTextEnd;

  if OrderPcUser=1 then Timer1.Enabled:=True;
end;


function TForm1.Cannot_UserPutPiece: boolean;
//ユーザーの置ける場所が無いか確認する。無ければTrue
var x,y:integer;
    flag:boolean;
begin
  flag:=False;
  for x := 0 to 7 do
    for y := 0 to 7 do
    begin
      if fBoard[x,y]=0 then
      begin
        if CanPutPieces(x,y,user_iro) then
          flag:=True;
      end;
    end;
  Result:=not flag;
end;


end.

実行ボタンを押す(WindowsでもAndroidでも動作します)