svn/view/Unit1.pas

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.AppEvnts, Vcl.Menus;

const
  Count = 4;
  Size = 16;
  Wid = 10;
  Hei = 15;

  pos_X = Wid div 2;
  pos_Y = 0;

type
  TBall = class(TObject)
  public
    X, Y: integer;
    Color: TColor;
    Index: integer;
    constructor Craete;
  end;

  TItem = class(TObject)
  private
    function GetColors(X: integer): TBall;
    procedure SetColors(X: integer; const Value: TBall);
    procedure SetLeft(const Value: integer);
    procedure SetTop(const Value: integer);
    function GetLeft: integer;
  protected
    FColors: array [0 .. Count - 1] of TBall;
  public
    Horizontal: Boolean;
    Visible: Boolean;
    constructor Create;
    destructor Destroy; override;
    procedure Clean;
    procedure Assign(Source: TItem);
    property Colors[X: integer]: TBall read GetColors write SetColors;
    property Left: integer read GetLeft write SetLeft;
    property Top: integer write SetTop;
  end;

  TGround = class(TObject)
  private
    function GetStrings(X, Y: integer): TBall;
    procedure SetStrings(X, Y: integer; const Value: TBall);
  protected
    FStrings: array [0 .. Wid - 1, 0 .. Hei - 1] of TBall;
  public
    Left, Top: integer;
    constructor Create;
    destructor Destroy; override;
    procedure Clean;
    procedure Assign(Source: TGround);
    property Strings[X, Y: integer]: TBall read GetStrings
      write SetStrings; default;
  end;

  TState = (Down, Shoot, Sys, Stop, Ojama, Effect);

  TDirector = (Under, Left, Right);

  TOjamaEvent = procedure(Sender: TObject; Count: integer) of object;

  TGameParam = record
    Rensa: integer;
    Kazu: integer;
    Group: integer;
  end;

  TScoreEvent = procedure(Sender: TObject; const GameParam: TGameParam;
    var Score: integer) of object;

  TPlayer = class(TObject)
  private
    Test: TItem;
    FOnCreateOjama: TOjamaEvent;
    BackGround: Boolean;
    FOnScoreEvent: TScoreEvent;
    FOnTextMessage: TNotifyEvent;
    FText: string;
    function Check(aItem: TItem): Boolean;
    procedure SetText(const Value: string);
  public
    Temp: TItem;
    Item: TItem;
    Ground: TGround;
    State: TState;
    Com: Boolean;
    Score: integer;
    OjamaList: TList;
    OjamaColor: TColor;
    EffectCount: integer;
    GameParam: TGameParam;
    TextColor: TColor;
    Name: string;
    constructor Create;
    destructor Destroy; override;
    procedure Start(const Resume: Boolean = false);
    procedure Execute;
    procedure Think;
    procedure Make(aCount: integer);
    procedure OjamaClean;
    function Remove: Boolean;
    function Move(Dir: TDirector): Boolean;
    function Turn(const Right: Boolean = true): Boolean;
    function Drop: Boolean;
    function Zenkesi: Boolean;
    property OnCreateOjama: TOjamaEvent read FOnCreateOjama
      write FOnCreateOjama;
    property OnScore: TScoreEvent read FOnScoreEvent write FOnScoreEvent;
    property Text: string read FText write SetText;
    property OnTextMessage: TNotifyEvent read FOnTextMessage
      write FOnTextMessage;
  end;

  TForm1 = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    MainMenu1: TMainMenu;
    Game1: TMenuItem;
    Start1: TMenuItem;
    N1: TMenuItem;
    Close1: TMenuItem;
    Com1: TMenuItem;
    Player11: TMenuItem;
    Player21: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure Player11Click(Sender: TObject);
    procedure Start1Click(Sender: TObject);
    procedure Close1Click(Sender: TObject);
  private
    { Private ���� }
    Buffer: TBitmap;
    TextMessage: string;
    Limit: TTime;
  public
    { Public ���� }
    Player1, Player2: TPlayer;
    Rensa: TThread;
    procedure CreateOjama(Sender: TObject; aCount: integer);
    procedure PlayerScore(Sender: TObject; const GameParam: TGameParam;
      var Score: integer);
    procedure PlayerMessage(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

{ TBall }

constructor TBall.Craete;
begin
  inherited;
  Color := clWhite;
end;

{ TItem }

procedure TItem.Assign(Source: TItem);
var
  i: integer;
begin
  Horizontal := Source.Horizontal;
  for i := 0 to Count - 1 do
  begin
    FColors[i].Color := Source.Colors[i].Color;
    FColors[i].X := Source.Colors[i].X;
    FColors[i].Y := Source.Colors[i].Y;
  end;
end;

procedure TItem.Clean;
var
  i, j: integer;
begin
  Horizontal := false;
  Randomize;
  for i := 0 to Count - 1 do
  begin
    FColors[i].X := pos_X;
    FColors[i].Y := pos_Y + i;
    j := Random(5);
    case j of
      0:
        FColors[i].Color := clRed;
      1:
        FColors[i].Color := clBlue;
      2:
        FColors[i].Color := clYellow;
      3:
        FColors[i].Color := clGreen;
      4:
        FColors[i].Color := clPurple;
    end;
  end;
end;

constructor TItem.Create;
var
  i: integer;
begin
  inherited;
  for i := 0 to Count - 1 do
    FColors[i] := TBall.Craete;
  Clean;
end;

destructor TItem.Destroy;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FColors[i].Free;
  inherited;
end;

function TItem.GetColors(X: integer): TBall;
begin
  result := FColors[X];
end;

function TItem.GetLeft: integer;
begin
  if Horizontal = true then
    result := Colors[0].X
  else
    result := Colors[Count - 1].X;
end;

procedure TItem.SetColors(X: integer; const Value: TBall);
begin
  FColors[X] := Value;
end;

procedure TItem.SetLeft(const Value: integer);
var
  i: integer;
  j: integer;
begin
  j := Value - Colors[0].X;
  for i := 0 to Count - 1 do
    Colors[i].X := Colors[i].X + j;
end;

procedure TItem.SetTop(const Value: integer);
var
  i: integer;
  j: integer;
begin
  j := Value - Colors[0].Y;
  for i := 0 to Count - 1 do
    Colors[i].Y := Colors[i].Y + j;
end;

{ TGround }

procedure TGround.Assign(Source: TGround);
var
  i: integer;
  j: integer;
begin
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
    begin
      Strings[i, j].Color := Source[i, j].Color;
      Strings[i, j].Index := Source[i, j].Index;
    end;
end;

procedure TGround.Clean;
var
  i: integer;
  j: integer;
begin
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
      FStrings[i, j].Color := clWhite;
end;

constructor TGround.Create;
var
  i: integer;
  j: integer;
begin
  inherited;
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
      FStrings[i, j] := TBall.Craete;
  Clean;
end;

destructor TGround.Destroy;
var
  i: integer;
  j: integer;
begin
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
      FStrings[i, j].Free;
  inherited;
end;

function TGround.GetStrings(X, Y: integer): TBall;
begin
  if (X < 0) or (Wid - 1 < X) or (Y < 0) or (Hei - 1 < Y) then
    result := nil
  else
    result := FStrings[X, Y];
end;

procedure TGround.SetStrings(X, Y: integer; const Value: TBall);
begin
  FStrings[X, Y] := Value;
end;

procedure TForm1.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
begin
  if Player1.State <> Stop then
  begin
    if Player2.State = Stop then
    begin
      TextMessage := 'Player1 WIN !!';
      Player1.State := Stop;
    end;
    Player1.Execute;
    Paint;
    Done := false;
  end
  else if Player2.State <> Stop then
  begin
    TextMessage := 'Player2 WIN !!';
    Player2.State := Stop;
  end;
end;

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

procedure TForm1.CreateOjama(Sender: TObject; aCount: integer);
begin
  if Sender = Player1 then
    Player2.Make(aCount)
  else
    Player1.Make(aCount);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Buffer := TBitmap.Create;
  Player1 := TPlayer.Create;
  Player2 := TPlayer.Create;
  Player2.Ground.Left := Player1.Ground.Left + (Size + 2) * Wid;
  Player1.OnCreateOjama := CreateOjama;
  Player2.OnCreateOjama := CreateOjama;
  Player1.OnScore := PlayerScore;
  Player2.OnScore := PlayerScore;
  Player1.OnTextMessage := PlayerMessage;
  Player2.OnTextMessage := PlayerMessage;
  Player1.Name := 'Player1';
  Player2.Name := 'Player2';
  Rensa := TRensa.Create;
  Player1.Com := true; { ComPlay }
  Player11.Checked := Player1.Com;
  Player1.Start;
  Buffer.Width := Player2.Ground.Left + Size * Wid;
  Buffer.Height := Hei * Size;
  Buffer.Canvas.Brush.Color := Color;
  Buffer.Canvas.FillRect(Rect(0, 0, Buffer.Width, Buffer.Height));
  Buffer.Canvas.Font.Style := [fsBold];
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Rensa.Terminate;
  Rensa.WaitFor;
  Rensa.Free;
  Buffer.Free;
  Player1.Free;
  Player2.Free;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then
    Close;
  if (Player1.State = Stop) and (Player2.State = Stop) then
  begin
    Player1.Start(true);
    Player2.Start(true);
    Buffer.Canvas.Brush.Color := Color;
    Buffer.Canvas.FillRect(Rect(0, 0, Buffer.Width, Buffer.Height));
    Limit := 0;
    Exit;
  end;
  if (Player1.Com = false) and (Player1.State = Down) then
  begin
    case Key of
      VK_DOWN:
        Player1.State := Shoot;
      VK_UP:
        Player1.Turn;
      VK_LEFT:
        Player1.Move(TDirector.Left);
      VK_RIGHT:
        Player1.Move(Right);
    end;
    Paint;
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  i: integer;
  s: TGround;

  procedure GroundDraw;
  var
    i: integer;
    j: integer;
    procedure Small(X, Y: integer);
    const
      a = Size div 8;
    begin
      Buffer.Canvas.Ellipse(X - a, Y - a, X + a, Y + a);
    end;

  begin
    for i := 0 to Wid - 1 do
      for j := 0 to Hei - 1 do
        if s[i, j].Color <> clWhite then
        begin
          Buffer.Canvas.Brush.Color := s[i, j].Color;
          if s[i, j].Index = -1 then
          begin
            Small(s.Left + i * Size, s.Top + j * Size);
            Small(s.Left + (i + 1) * Size, s.Top + j * Size);
            Small(s.Left + i * Size, s.Top + (j + 1) * Size);
            Small(s.Left + (i + 1) * Size, s.Top + (j + 1) * Size);
            Small(s.Left + i * Size + (Size div 2),
              s.Top + j * Size + (Size div 2));
          end
          else
            Buffer.Canvas.Ellipse(s.Left + i * Size, s.Top + j * Size,
              s.Left + (i + 1) * Size, s.Top + (j + 1) * Size);
        end;
  end;

  procedure OjamaDraw(aPlayer: TPlayer);
  var
    i: integer;
    t: TBall;
  begin
    if aPlayer.State <> Ojama then
      Exit;
    Buffer.Canvas.Brush.Color := clGray;
    for i := 0 to aPlayer.OjamaList.Count - 1 do
    begin
      t := aPlayer.OjamaList[i];
      Buffer.Canvas.Ellipse(s.Left + t.X * Size, s.Top + t.Y * Size,
        s.Left + (t.X + 1) * Size, s.Top + (t.Y + 1) * Size);
    end;
  end;

  procedure ItemDraw(aItem: TItem);
  var
    k: integer;
  begin
    with aItem do
    begin
      if Visible = false then
        Exit;
      for k := 0 to Count - 1 do
      begin
        Buffer.Canvas.Brush.Color := Colors[k].Color;
        Buffer.Canvas.Ellipse(s.Left + Colors[k].X * Size,
          s.Top + Colors[k].Y * Size, s.Left + (Colors[k].X + 1) * Size,
          s.Top + (Colors[k].Y + 1) * Size);
      end;
    end;
  end;

  procedure Main;
  begin
    Buffer.Canvas.FillRect(Rect(s.Left, s.Top, s.Left + Wid * Size,
      s.Top + Hei * Size));
    GroundDraw;
  end;

begin
  Buffer.Canvas.Brush.Color := Color;
  Buffer.Canvas.FillRect(Rect(Player1.Ground.Left + Wid * Size, 0,
    Player2.Ground.Left, Hei * Size));
  Buffer.Canvas.Brush.Color := clWhite;
  if Sender = nil then
  begin
    s := Player2.Ground;
    Main;
    ItemDraw(Player2.Item);
    OjamaDraw(Player2);
  end
  else if Sender = Player2 then
  begin
    s := Player1.Ground;
    Main;
    ItemDraw(Player1.Item);
    OjamaDraw(Player1);
  end
  else
  begin
    s := Player1.Ground;
    Main;
    ItemDraw(Player1.Item);
    OjamaDraw(Player1);
    Buffer.Canvas.Brush.Color := clWhite;
    s := Player2.Ground;
    Main;
    ItemDraw(Player2.Item);
    OjamaDraw(Player2);
  end;
  if Limit > 0 then
  begin
    i := (Buffer.Width - Buffer.Canvas.TextWidth(TextMessage)) div 2;
    Buffer.Canvas.Brush.Color := Color;
    Buffer.Canvas.TextOut(i, 0, TextMessage);
    if Time > Limit then
    begin
      Limit := 0;
      FormPaint(Sender);
    end;
  end;
  Canvas.Draw(100, 50, Buffer);
end;

procedure TForm1.Player11Click(Sender: TObject);
begin
  Player11.Checked := not Player11.Checked;
  Player1.Com := Player11.Checked;
  Start1Click(Sender);
end;

procedure TForm1.PlayerMessage(Sender: TObject);
var
  s: TPlayer;
begin
  s := Sender as TPlayer;
  if s.State = Stop then
  begin
    if s = Player1 then
      TextMessage := 'Player2 WIN !!'
    else
      TextMessage := 'Player1 WIN !!';
  end
  else
    TextMessage := s.Text;
  Canvas.Font.Color := s.TextColor;
  Limit := Time + 1 / (24 * 60 * 60);
end;

procedure TForm1.PlayerScore(Sender: TObject; const GameParam: TGameParam;
  var Score: integer);
begin
  with GameParam do
    Score := Rensa * Rensa * 10 + Group * Group * 15;
end;

procedure TForm1.Start1Click(Sender: TObject);
begin
  Rensa.Terminate;
  Rensa.WaitFor;
  Rensa.Free;
  Rensa := TRensa.Create;
  Player1.Start(true);
end;

{ TPlayer }

constructor TPlayer.Create;
begin
  State := TState.Stop;
  Item := TItem.Create;
  Temp := TItem.Create;
  Test := TItem.Create;
  Ground := TGround.Create;
  OjamaList := TList.Create;
end;

destructor TPlayer.Destroy;
begin
  Item.Free;
  Temp.Free;
  Test.Free;
  Ground.Free;
  OjamaClean;
  OjamaList.Free;
  inherited;
end;

procedure TPlayer.Make(aCount: integer);
var
  i: integer;
  s: TBall;
  j, k, m: integer;
  t: TStringList;
  function Full: Boolean;
  var
    n: integer;
    p: integer;
  begin
    p := 0;
    for n := 0 to OjamaList.Count - 1 do
    begin
      s := OjamaList[n];
      if s.Y = m then
        inc(p);
    end;
    result := p = Wid;
  end;

begin
  if aCount = 0 then
    Exit;
  for i := OjamaList.Count - 1 downto 0 do
  begin
    s := OjamaList[i];
    if (s.Y < 0) and (aCount > 0) then
    begin
      s.Free;
      OjamaList.Delete(i);
      dec(aCount);
    end
    else
    begin
      m := s.Y - 1;
      break;
    end;
  end;
  j := 0;
  while aCount >= Wid do
  begin
    for i := 0 to Wid - 1 do
    begin
      s := TBall.Craete;
      s.X := i;
      s.Y := j;
      s.Color := clGray;
      OjamaList.Add(s);
    end;
    dec(aCount, Wid);
    dec(j);
  end;
  t := TStringList.Create;
  try
    for i := 0 to Wid - 1 do
      t.Add(IntToStr(i));
    Randomize;
    for i := 1 to aCount do
    begin
      k := Random(t.Count);
      s := TBall.Create;
      s.X := StrToInt(t[k]);
      s.Y := j;
      s.Color := clGray;
      t.Delete(k);
      OjamaList.Add(s);
      if Full = true then
        dec(j);
    end;
  finally
    t.Free;
  end;
end;

function TPlayer.Move(Dir: TDirector): Boolean;
var
  i: integer;
  s: TItem;
begin
  result := true;
  s := TItem.Create;
  try
    s.Assign(Item);
    case Dir of
      Under:
        begin
          for i := 0 to Count - 1 do
            s.Colors[i].Y := s.Colors[i].Y + 1;
          if Check(s) = true then
            Item.Assign(s)
          else
          begin
            State := Sys;
            GameParam.Rensa := 0;
            Item.Visible := false;
            for i := 0 to Count - 1 do
              Ground[Item.Colors[i].X, Item.Colors[i].Y].Color :=
                Item.Colors[i].Color;
            result := false;
          end;
        end;
      Left:
        begin
          for i := 0 to Count - 1 do
            s.Colors[i].X := s.Colors[i].X - 1;
          if Check(s) = true then
            Item.Assign(s)
          else
            result := false;
        end;
      Right:
        begin
          for i := 0 to Count - 1 do
            s.Colors[i].X := s.Colors[i].X + 1;
          if Check(s) = true then
            Item.Assign(s)
          else
            result := false;
        end;
    end;
  finally
    s.Free;
  end;
end;

procedure TPlayer.OjamaClean;
var
  i: integer;
  s: TBall;
begin
  for i := 0 to OjamaList.Count - 1 do
  begin
    s := OjamaList[i];
    s.Free;
  end;
  OjamaList.Clear;
end;

function TPlayer.Remove: Boolean;
var
  Index: integer;
  s: TColor;
  i: integer;
  j: integer;
  function MapIndex(X, Y: integer): Boolean;
  var
    p: TBall;
  begin
    result := true;
    if (Ground[X, Y] = nil) or (Ground[X, Y].Color = clGray) then
    begin
      result := false;
      Exit;
    end;
    if Ground[X, Y].Color = s then
    begin
      p := Ground[X, Y];
      if (p.Index = 0) and (p.Color = s) then
      begin
        Ground[X, Y].Index := Index;
        MapIndex(X - 1, Y - 1);
        MapIndex(X, Y - 1);
        MapIndex(X + 1, Y - 1);
        MapIndex(X - 1, Y);
        MapIndex(X + 1, Y);
        MapIndex(X - 1, Y + 1);
        MapIndex(X, Y + 1);
        MapIndex(X + 1, Y + 1);
      end
      else
        result := false;
    end;
  end;
  function CheckIndex(X: integer): integer;
  var
    m, n: integer;
  begin
    result := 0;
    for m := 0 to Wid - 1 do
      for n := 0 to Hei - 1 do
        if Ground[m, n].Index = X then
          inc(result);
  end;
  procedure DeleteOjama(const Ojama: array of TBall);
  var
    m: integer;
  begin
    for m := Low(Ojama) to High(Ojama) do
      if (Ojama[m] <> nil) and (Ojama[m].Color = clGray) then
        Ojama[m].Color := clWhite;
  end;
  procedure Delete(X: integer);
  var
    m, n: integer;
  begin
    for m := 0 to Wid - 1 do
      for n := 0 to Hei - 1 do
        if Ground[m, n].Index = X then
        begin
          if BackGround = true then
            Ground[m, n].Color := clWhite
          else
            Ground[m, n].Index := -1;
          DeleteOjama([Ground[m - 1, n], Ground[m + 1, n], Ground[m, n - 1],
            Ground[m, n + 1]]);
        end;
  end;

begin
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
      Ground[i, j].Index := 0;
  Index := 1;
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
    begin
      s := Ground[i, j].Color;
      if (s <> clWhite) and (s <> OjamaColor) then
        if MapIndex(i, j) = true then
          inc(Index);
    end;
  GameParam.Kazu := 0;
  Score := 0;
  result := false;
  for i := 1 to Index do
  begin
    j := CheckIndex(i);
    if j = 3 then
      inc(GameParam.Group);
    if j >= 4 then
    begin
      inc(GameParam.Kazu, j);
      inc(GameParam.Rensa);
      inc(Score, 5 * j);
      Delete(i);
      result := true;
    end;
    inc(Score, GameParam.Rensa * 10);
    if Assigned(FOnScoreEvent) = true then
      FOnScoreEvent(Self, GameParam, Score);
  end;
  if GameParam.Rensa >= 2 then
    Text := Name + Format(' %d �A��', [GameParam.Rensa]);
end;

function TPlayer.Drop: Boolean;
var
  i: integer;
  j: integer;
  k: integer;
begin
  result := false;
  for i := 0 to Wid - 1 do
    for j := Hei - 1 downto 1 do
      if Ground[i, j].Color = clWhite then
      begin
        for k := j downto 1 do
        begin
          Ground[i, k].Color := Ground[i, k - 1].Color;
          Ground[i, k].Index := Ground[i, k - 1].Index;
          if Ground[i, k].Color <> clWhite then
            result := true;
        end;
        Ground[i, 0].Color := clWhite;
        Ground[i, 0].Index := 0;
      end;
end;

procedure TPlayer.Execute;
  function Same: Boolean;
  var
    k: integer;
  begin
    result := true;
    for k := 0 to Count - 1 do
      if Item.Colors[k].Color <> Test.Colors[k].Color then
      begin
        result := false;
        break;
      end;
  end;

var
  i, j: integer;
  s: TBall;

begin
  case State of
    Down:
      if Com = true then
      begin
        if (Item.Horizontal <> Test.Horizontal) or (Same = false) then
          Turn
        else if Item.Left = Test.Left then
          State := Shoot
        else if Item.Left < Test.Left then
          Item.Left := Item.Left + 1
        else
          Item.Left := Item.Left - 1;
        Sleep(100);
      end
      else
      begin
        Move(Under);
        for i := 1 to 100 do
        begin
          Sleep(3);
          Application.ProcessMessages;
          if State <> Down then
            break;
        end;
      end;
    Shoot:
      begin
        Move(Under);
        Sleep(100);
      end;
    Sys:
      if Drop = true then
        Sleep(100)
      else if Remove = true then
      begin
        State := Effect;
        EffectCount := 1;
      end
      else
      begin
        State := Ojama;
        if Assigned(FOnCreateOjama) = true then
          FOnCreateOjama(Self, GameParam.Rensa - 1);
        if (Zenkesi = true) and (Assigned(FOnCreateOjama) = true) then
          FOnCreateOjama(Self, 2 * Wid);
      end;
    Effect:
      begin
        case EffectCount of
          0:
            State := Sys;
          1:
            for i := 0 to Wid - 1 do
              for j := 0 to Hei - 1 do
                if Ground[i, j].Index = -1 then
                begin
                  Ground[i, j].Color := clWhite;
                  Ground[i, j].Index := 0;
                end;
        end;
        Sleep(100);
        dec(EffectCount);
      end;
    Ojama:
      if OjamaList.Count = 0 then
        Start
      else
      begin
        for i := 0 to OjamaList.Count - 1 do
        begin
          s := OjamaList[i];
          if (s.Y < Hei - 1) and
            ((s.Y < 0) or (Ground[s.X, s.Y + 1].Color = clWhite)) then
            s.Y := s.Y + 1
          else if (s.Y = 0) and (Ground[s.X, 0].Color <> clWhite) then
          begin
            State := Stop;
            Exit;
          end
          else
          begin
            Ground[s.X, s.Y].Color := clGray;
            s.Color := clWhite;
          end;
        end;
        for i := OjamaList.Count - 1 downto 0 do
        begin
          s := OjamaList[i];
          if s.Color = clWhite then
          begin
            s.Free;
            OjamaList.Delete(i);
          end;
        end;
        Sleep(100);
      end;
  end;
end;

procedure TPlayer.SetText(const Value: string);
begin
  FText := Value;
  if Assigned(FOnTextMessage) = true then
    FOnTextMessage(Self);
end;

procedure TPlayer.Start(const Resume: Boolean);
begin
  OjamaClean;
  if Resume = true then
  begin
    Temp.Clean;
    Item.Visible := false;
    Ground.Clean;
  end;
  Item.Assign(Temp);
  Item.Visible := true;
  if Check(Item) = false then
  begin
    State := TState.Stop;
    Text := Name + 'Game Over';
  end
  else
  begin
    if Com = true then
      Think;
    State := Down;
  end;
  Temp.Clean;
end;

function TPlayer.Check(aItem: TItem): Boolean;
var
  i: integer;
  s: TBall;
begin
  result := true;
  for i := 0 to Count - 1 do
  begin
    s := Ground[aItem.Colors[i].X, aItem.Colors[i].Y];
    if (s = nil) or (s.Color <> clWhite) then
    begin
      result := false;
      break;
    end;
  end;
end;

procedure TPlayer.Think;
const
  Hei = 100;
var
  s: TGround;
  i: integer;
  k, m: integer;
  procedure Sub;
  var
    j: integer;
  begin
    k := -1;
    for j := 0 to Wid - 1 do
    begin
      Item.Left := j;
      Item.Top := 0;
      if Check(Item) = false then
        continue;
      while true do
        if Move(Under) = false then
          break;
      m := 0;
      while true do
        if Drop = false then
        begin
          if Remove = false then
            break;
          inc(m, Score);
        end;
      Ground.Assign(s);
      if m > k then
      begin
        k := m;
        Test.Assign(Item);
      end;
      if k >= Hei then
        break;
    end;
  end;

begin
  BackGround := true;
  s := TGround.Create;
  try
    s.Assign(Ground);
    for i := 1 to 3 do
    begin
      Sub;
      if k >= Hei then
        break;
      Turn;
    end;
    Item.Left := pos_X;
    Item.Top := 0;
    Item.Visible := true;
  finally
    BackGround := false;
    s.Free;
  end;
  Item.Assign(Temp);
end;

function TPlayer.Turn(const Right: Boolean): Boolean;
var
  i: integer;
  s: TItem;
  procedure return(var aItem: TItem);
  var
    p: array [0 .. Count - 1] of TColor;
    j: integer;
  begin
    for j := 0 to Count - 1 do
      p[j] := aItem.Colors[Count - j - 1].Color;
    for j := 0 to Count - 1 do
      aItem.Colors[j].Color := p[j];
  end;

begin
  s := TItem.Create;
  try
    s.Assign(Item);
    s.Horizontal := not s.Horizontal;
    if ((not s.Horizontal = true) and (Right = true)) or
      ((not s.Horizontal = false) and (Right = false)) then
      return(s);
    for i := 0 to Count - 1 do
    begin
      if s.Horizontal = true then
      begin
        s.Colors[i].X := s.Colors[i].X + s.Colors[0].Y - s.Colors[i].Y;
        s.Colors[i].Y := s.Colors[0].Y;
      end
      else
      begin
        s.Colors[i].Y := s.Colors[i].Y + s.Colors[0].X - s.Colors[i].X;
        s.Colors[i].X := s.Colors[0].X;
      end;
    end;
    result := Check(s);
    if result = true then
      Item.Assign(s)
    else
    begin
      for i := 0 to Count - 1 do
        s.Colors[i].X := s.Colors[i].X + 1;
      if Check(s) = true then
      begin
        Item.Assign(s);
        result := true;
      end
      else
      begin
        for i := 0 to Count - 1 do
          s.Colors[i].X := s.Colors[i].X - 2;
        if Check(s) = true then
        begin
          Item.Assign(s);
          result := true;
        end
        else
          result := false;
      end;
    end;
  finally
    s.Free;
  end;
end;

function TPlayer.Zenkesi: Boolean;
var
  i: integer;
  j: integer;
begin
  for i := 0 to Wid - 1 do
    for j := 0 to Hei - 1 do
      if (Ground[i, j].Color <> clWhite) and (Ground[i, j].Color <> clGray) then
      begin
        result := false;
        Exit;
      end;
  result := true;
end;

end.