unboundmodedemominercore.pas

DevExpress ExpressQuantumGrid Suite v5.9 Full Source

unit UnboundModeDemoMinerCore;

interface

uses
  UnboundModeDemoTypes;

type
  TMinerField = class(TObject)
  private
    FHeight: Integer;
    FWidth: Integer;
    FMineCount: Integer;
    FCellState: TCellStateRecArrArr;
    FGameDifficulty: TGameDifficulty;
    FGameStatus: TGameStatus;
    FCellsBombMarkedCount: Integer;
    FRedCells: TCells;
    FMinerFieldChanged: TSrcMinerFieldChangedEvent;
    FGameStatusChanged: TSrcGameStatusChangedEvent;
    function CheckFieldBounds(AXPos, AYPos: Integer): Boolean;

    function Get_Height: Integer;
    procedure Set_Height(const Value: Integer);

    function Get_Widht: Integer;
    procedure Set_Width(const Value: Integer);

    function Get_MineCount: Integer;
    procedure Set_MineCount(const Value: Integer);

    function Get_CellState(XIndex, YIndex: Integer): TCellStateRec;
    procedure Set_CellState(XIndex, YIndex: Integer; const Value: TCellStateRec);

    function Get_GameDifficulty: TGameDifficulty;
    procedure Set_GameDifficulty(const Value: TGameDifficulty);

    procedure OpenSurround(AXPos, AYPos: Integer; var AChangedCells: TCells);
    function Get_GameStatus: TGameStatus;
    procedure Set_GameStatus(const Value: TGameStatus);

    procedure CreateNewGame;
    function IsGameFinished: Boolean;


    procedure FireEvGameStatusChanged(AGameStatus: TGameStatus; var AChangedCells: TCells);
    procedure FireEvMinerFieldChanged(var AChangedCells: TCells);

    property GameDifficulty: TGameDifficulty read Get_GameDifficulty write Set_GameDifficulty;
    property CellState[XIndex, YIndex: Integer]: TCellStateRec read Get_CellState write Set_CellState;
    property Height: Integer read Get_Height write Set_Height;
    property Width: Integer read Get_Widht write Set_Width;
    property MineCount: Integer read Get_MineCount write Set_MineCount;
    property GameStatus: TGameStatus read Get_GameStatus write Set_GameStatus;
    procedure FillBombCells(var AChangedCells: TCells);
  protected
    procedure DropMines(AFirstX, AFirstY: Integer); virtual;
    procedure OpenCell(AXPos, AYPos: Integer); virtual;
    procedure BombMarkCell(AXPos, AYPos: Integer); virtual;
    procedure QuestionMarkCell(AXPos, AYPos: Integer); virtual;
    procedure CloseCell(AXPos, AYPos: Integer); virtual;
    procedure CheckSurround(AXPos, AYPos: Integer); virtual;
  public
    property OnMinerFieldChanged: TSrcMinerFieldChangedEvent read FMinerFieldChanged write FMinerFieldChanged;
    property OnGameStatusChanged: TSrcGameStatusChangedEvent read FGameStatusChanged write FGameStatusChanged;

    constructor Create; overload;
    destructor Destroy; override;
    { Event handlers }
    procedure HandleEvCreateNewGame(Sender: TObject);
    procedure HandleEvChangeGameDifficulty(Sender: TObject; const AGameDifficulty: TGameDifficulty);
    procedure HandleMinerFieldActionEvent(Sender: TObject; ACol, ARow: Integer; AMinerFieldEventType: TMinerFieldActionEventType);
  end;

var
  MinerField: TMinerField;

implementation

uses Dialogs, SysUtils, Windows, Classes;

{ TMinerField }

constructor TMinerField.Create;
begin
  inherited Create;
  FGameStatus := gsNew;
end;

destructor TMinerField.Destroy;
begin
  FRedCells := nil;
  FCellState := nil;
  inherited Destroy;
end;

function TMinerField.Get_Height: Integer;
begin
  Result := FHeight;
end;

procedure TMinerField.Set_Height(const Value: Integer);
begin
  if (9 <= Value) and (Value <= 24) then
    FHeight := Value else
  if Value < 9 then
    FHeight := 9 else
  if 24 < Value then
    FHeight := 24;
end;

function TMinerField.Get_Widht: Integer;
begin
  Result := FWidth;
end;

procedure TMinerField.Set_Width(const Value: Integer);
begin
  if (9 <= Value) and (Value <= 30) then
    FWidth := Value else
  if (Value < 9) then
    FWidth := 9 else
  if 30 < Value then
    FWidth := 30;
end;

function TMinerField.Get_MineCount: Integer;
begin
  Result := FMineCount;
end;

procedure TMinerField.Set_MineCount(const Value: Integer);
begin
  if (10 <= Value) and (Value <= (FHeight - 1)*(FWidth - 1)) then
    FMineCount := Value else
  if Value < 10 then
    FMineCount := 10 else
  if (FHeight - 1)*(FWidth - 1) < Value then
    FMineCount := (FHeight - 1)*(FWidth - 1);
end;

function TMinerField.Get_CellState(XIndex, YIndex: Integer): TCellStateRec;
begin
  Result := FCellState[XIndex, YIndex];
end;

procedure TMinerField.Set_CellState(XIndex, YIndex: Integer;
  const Value: TCellStateRec);
begin
  if (FCellState[XIndex, YIndex].SurroundNumber <> Value.SurroundNumber) or
    (FCellState[XIndex, YIndex].CellState <> Value.CellState) then
    begin
      if FCellState[XIndex, YIndex].CellState = csBombMarked then
        Dec(FCellsBombMarkedCount);

      FCellState[XIndex, YIndex] := Value;
      if Value.CellState = csBombMarked then
        Inc(FCellsBombMarkedCount);
    end;
end;

procedure TMinerField.CheckSurround(AXPos, AYPos: Integer);
var
  WrongBombMark: Boolean;
  ChangedCells: TCells;
  function IsCountBombMarkedCorrect(AXPos, AYPos: Integer): Boolean;
  var
    RealBombCount: Integer;
    BombMarked: Integer;
    i, j: Integer;
  begin
    BombMarked := 0;
    RealBombCount := 0;
    for i:=-1 to 1 do
      for j:=-1 to 1 do
        if CheckFieldBounds(AXPos+i, AYPos+j) then
        begin
          if FCellState[AXPos+i, AYPos+j].CellState = csBombMarked then
          begin
            Inc(BombMarked);
            if FCellState[AXPos+i, AYPos+j].SurroundNumber <> -1 then
              WrongBombMark := True
          end;
          if FCellState[AXPos+i, AYPos+j].SurroundNumber = -1 then
          begin
            SetLength(FRedCells, Length(FRedCells)+1);
            FRedCells[High(FRedCells)].x := AXPos+i;
            FRedCells[High(FRedCells)].y := AYPos+j;
            Inc(RealBombCount);
          end;
        end;
    Result := RealBombCount = BombMarked;
  end;
begin
  if (FCellState[AXPos, AYPos].CellState = csBombMarked) or
    (FCellState[AXPos, AYPos].CellState = csClosed) or
    (FCellState[AXPos, AYPos].CellState = csQuestionMarked) then
    Exit;

  // check whether csBombMarked Cells set well
  WrongBombMark := False;
  if not IsCountBombMarkedCorrect(AXPos, AYPos) then
  begin
    FRedCells := nil;
    Exit;
  end;

  // open surrounding csClosed Cells
  OpenSurround(AXPos, AYPos, ChangedCells);

  if WrongBombMark then
  begin
    FGameStatus := gsLost;
    FillBombCells(ChangedCells);
    FireEvGameStatusChanged(gsLost, ChangedCells);
    Exit;
  end;
  FRedCells := nil;

  FireEvMinerFieldChanged(ChangedCells);
  if IsGameFinished then
  begin
    FGameStatus := gsWon;
    FillBombCells(ChangedCells);
    FireEvGameStatusChanged(gsWon, ChangedCells);
  end;
end;

procedure TMinerField.CreateNewGame;
var
  i, j: Integer;
begin
  FCellsBombMarkedCount := 0;
  FRedCells := nil;
  FCellState := nil;
  SetLength(FCellState, FWidth);
  for i:=0 to FWidth - 1 do
  begin
    SetLength(FCellState[i], FHeight);
    for j:=0 to FHeight - 1 do
      FCellState[i, j].CellState := csClosed;
  end;
end;

procedure TMinerField.FillBombCells(var AChangedCells: TCells);
var
  i, j: Integer;
begin
  for i:=0 to High(FCellState) do
    for j:=0 to High(FCellState[i]) do
      if FCellState[i,j].SurroundNumber = -1 then
      begin
        SetLength(AChangedCells, Length(AChangedCells) + 1);
        AChangedCells[High(AChangedCells)] := Point(i, j);
      end;
end;

procedure TMinerField.OpenCell(AXPos, AYPos: Integer);
var
  ChangedCells: TCells;
begin
  if GameStatus = gsNew then
  begin
    DropMines(AXPos, AYPos);
    FGameStatus := gsRun;
    FireEvGameStatusChanged(gsRun, ChangedCells);
  end;

  if FCellState[AXPos, AYPos].CellState = csBombMarked then
    Exit;
  if FCellState[AXPos, AYPos].SurroundNumber = -1 then
  begin
    // Stop current game
    FGameStatus := gsLost;
    SetLength(FRedCells, Length(FRedCells)+1);
    FRedCells[0].x := AXPos; FRedCells[0].y := AYPos;
    FillBombCells(ChangedCells);
    FireEvGameStatusChanged(gsLost, ChangedCells);
    Exit;
  end;

  if FCellState[AXPos, AYPos].SurroundNumber <> 0 then
  begin
    FCellState[AXPos, AYPos].CellState := csOpened;
    SetLength(ChangedCells, 1);
    ChangedCells[0].x := AXPos; ChangedCells[0].y := AYPos;
  end
  else
    OpenSurround(AXPos, AYPos, ChangedCells);
  FireEvMinerFieldChanged(ChangedCells);