board.pas

来自「用于开发税务票据管理的软件」· PAS 代码 · 共 1,705 行 · 第 1/5 页

    procedure ChangeGridLineWidth(const NewVal: Cardinal);
    procedure ChangeHighlightWidth(const NewVal: Cardinal);
    procedure ChangeDrawGridLines(const NewVal: Boolean);
    procedure ChangePic(const NewVal: TPicture);
    procedure ChangePieceFilter(const NewVal: ShortString);
    procedure ChangeShowHints(const NewVal: Boolean);
    procedure ChangeShowSquareHighlights(const NewVal: Boolean);
    procedure ChangeSmoothPieces(const NewVal: Boolean);
    procedure ChangeSquareSize(const NewVal: Cardinal);
    procedure ChangeStretch(const NewVal: Boolean);
    procedure ChangeStretchPic(const NewVal: Boolean);
    procedure ChangeUndoLimit(const NewVal: Byte);
    procedure ChangeWhiteSquareColour(const NewVal: TColor);
    procedure ClearPieces;
    procedure DeletePiece(const Which: TPiece);
    procedure DrawGridlines(DrawCanvas: TCanvas);
    procedure DropUndoRecords(const HowMany: Byte);
    procedure EraseSquare(const Where: TPoint; const p: TPiece);
    procedure HighlightBoardSquare(const Where: TPoint; const MovingEnemy: Boolean);
    procedure HighlightSquares(const HowMany: Cardinal; const MovingEnemy: Boolean);
    procedure InitialisePieces;
    procedure PromotePawn(LuckyPawn: TPawn); // gets piece type, calls PromotePawnToPiece
    procedure PromotePawnToPiece(LuckyPawn: TPawn; const PieceType: TPromotedPiece);
    procedure ResetPieceBits;
    procedure SendEndTurnEvent;
    procedure SetupPieces;
    procedure ShowMeMessage2(const NewVal: ShortString);
//    procedure SortBoard;
    procedure UncapturePiece(UncapturedPiece: TPiece);
    procedure UpdateGameTime(Sender: TObject);
    procedure UpdateUndoRecords(const From, WhereTo: TPoint; const PositionMove: Boolean);
    procedure UndrawGridLines(DrawCanvas: TCanvas);

//    function CalculateHash(const p: TPoint): Cardinal;
    function CanRedo: Boolean;
    function CanUndo: Boolean;
    function CheckCastling(const NumberOfSquares: Cardinal): Boolean;
    function CheckForCheckmate: Boolean;
    function CheckForGameEnd: Boolean;
    function CheckForRepetition: Boolean;
    function CheckForStalemate: Boolean;
    function CheckPieceCounts(const A: TPiecesCountArray): Boolean;
    function CheckForDefaultPieces: Boolean;
    function ComparePoints(const P1, P2: TPoint): Boolean;
    function CompareUndoRecords(const R1, R2: TUndoRecordPtr): Boolean;
    function FindKing(var pKing: TPiece; const WhichColour: TColour): TPoint;
    function FindNewLocation(const X,Y: Cardinal): TPoint; register;
    function FindPiece(var ReturnThis: TPiece; const Where: TPoint): Boolean; register;
    function GetPieceFilter: ShortString;
    function GetPointsBlack: Byte;
    function GetPointsWhite: Byte;
    function GetSquareColour(Where: TPoint): TColor;
    function InBounds(const Where: TPoint): Boolean;
    //function KingInCheck(WhichColour: TColour): Boolean; // not used.  Maybe use with AI evaluate() function
    function MoveAndCheck(FromPiece, WhereToPiece: TPiece;
                    const KingLocation: TPoint; const EnemyColour: TColour ): Boolean;
    function MovePiece(var P: TPiece; const WhereTo: TPoint): Boolean;
    procedure MovePieceToSquare(P: TPiece; const WhereTo: TPoint);
    function PieceCanAttackSquare(const p: TPiece; const Where: TPoint): Boolean;
    function PiecesAttackingSquare(const WhereTo: TPoint; const WhatColour: TColour): Cardinal;
    function PiecesInWay(const From, WhereTo: TPoint): Boolean;
    function ShowMeMessage1: ShortString;
    function ValidMove(const From, WhereTo: TPoint): Boolean;
  protected
    { Protected declarations }
    procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;

    // I handle these directly to do drag-n-drop, for display purposes
    procedure WMBeginDrag(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMStopDrag(var Msg: TWMLButtonUp); message WM_LBUTTONUP;

    // These are used when positioning mode is set to true
    procedure PositionMove(const MoveTo: TPoint);
    procedure PositionDrop(const DropLocation: TPoint);

    procedure ShowValidMoves(const PieceWhere: TPiece);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;

    function LoadGame(const FileName: String): Boolean;
    function SaveGame(const FileName: String): Boolean;

    procedure ForceRedraw;
    procedure FinishCurrentGame;
    procedure Pause;
    procedure Redo;
    procedure ResetBoard;
    procedure Unpause;

    function DrawCapturedPieces(Bmp: TBitmap; WhatColour: TColour;
                                     pprow, w,h: Byte): Byte;
    function GetBoardCount: Cardinal;
    function GetPointsTotal(Colour: TColour): Cardinal;
    function Undo: Boolean;

    property Check: Boolean Read FCheck;
    property GameRunning: Boolean Read FGameRunning;
    property PointsBlack: Byte Read GetPointsBlack;
    property PointsWhite: Byte Read GetPointsWhite;
    property PositionMode: Boolean Read FPositionMode Write FPositionMode;
    property Turn: byte Read FTurn;
    property TurnNumber: Cardinal Read FTurnNumber;
    property UndoPossible: Boolean Read CanUndo;
    property RedoPossible: Boolean Read CanRedo;
  published
    { Published declarations }
    property Author: ShortString Read ShowMeMessage1 Write ShowMeMessage2;
    property BackgroundColour: TColor Read FBackgroundC Write ChangeBackgroundColour;
    property BlackSquareColour: TColor Read FBlackC Write ChangeBlackSquareColour default clGray;
    property DrawLines: Boolean Read FDrawLines Write ChangeDrawGridLines default True;
    property GridLineColour: TColor Read FGridLineColour Write ChangeGridLineColour;
    property GridLineWidth: Cardinal Read FGridlineWidth Write ChangeGridlineWidth;
    property HighlightCaptureColour: TColor Read FHighlightCaptureColour Write FHighlightCaptureColour default clLime;
    property HighlightColour: TColor Read FHighlightColour Write FHighlightColour default clYellow;
    property HighlightEnemyColour: TColor Read FHighlightEnemyColour Write FHighlightEnemyColour default clRed;
    property HighlightStartSquare: Boolean Read FHighlightStartSquare Write FHighlightStartSquare default True;
    property HighlightWidth: Cardinal Read FHighlightWidth Write ChangeHighlightWidth;
    property Picture: TPicture Read FPic Write ChangePic;
    property PieceFilter: ShortString Read GetPieceFilter Write ChangePieceFilter;
    property ShowPieceHints: Boolean Read FShowHints Write ChangeShowHints default True;
    property ShowSquareHighlights: Boolean Read FShowSquareHighlights Write ChangeShowSquareHighlights default True;
    property ShowValidMovesMode: Boolean Read FShowValidMoves Write FShowValidMoves;
    property SmoothPieces: Boolean Read FSmoothPieces Write ChangeSmoothPieces;
    property StartDragColour: TColor Read FStartDragColour Write FStartDragColour default clYellow;
    property Stretch: Boolean Read FStretch Write ChangeStretch default True;
    property StretchPicture: Boolean Read FStretchPic Write ChangeStretchPic default True;
    property TimeBlack: Cardinal Read FTimeBlack;
    property TimeLimit: Cardinal Read FTimeLimit Write FTimeLimit;
    property TimeLimitEnabled: Boolean Read FTimerEnabled Write FTimerEnabled;
    property TimeWhite: Cardinal Read FTimeWhite;
    property UndoLimit: Byte Read FUndoLimit Write ChangeUndoLimit;
    property ValidMoveDragColour: TColor Read FValidMoveDragColour Write FValidMoveDragColour default clGreen;
    property WhiteSquareColour: TColor Read FWhiteC Write ChangeWhiteSquareColour default clSilver;
    property WidthOfSquares: Cardinal Read FSquareSize Write ChangeSquareSize;
    // NOTE: The above "WidthOfSquares" was originally called the more logical
    // "SquareSize".  However, it must come after "Stretch" alphabetically or
    // setting it at design-time doesn't work right!  You previously had to set
    // "SquareSize" at run-time to get it working!

    property OnCheckmate: TNotifyCheckmate Read FOnCheckMate Write FOnCheckMate default nil;
    property OnDraw: TNotifyDraw Read FOnDraw Write FOnDraw default nil;
    property OnEndTurn: TNotifyEndTurn Read FOnEndTurn Write FOnEndTurn default nil;
    property OnPositionMove: TNotifyPositionMove Read FOnPositionMove Write FOnPositionMove default nil;
    property OnTimeLoss: TNotifyTimeLoss Read FOnTimeLoss Write FOnTimeLoss default nil;

    { Republish some properties }
    property Align;
    property Cursor;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Hint;
    property OnClick;
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
  end;

procedure Register;

const
  crNoMove = 1;
  crYesMove = 2;

implementation

{$R CURSORS.RES}

constructor TChessboard.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Screen.Cursors[crNoMove] := LoadCursor(hInstance, 'NOMOVE');
  Screen.Cursors[crYesMove] := LoadCursor(hInstance, 'YESMOVE');

  FLastPawnMoved := nil;
  FLoading := False;

  ControlStyle := ControlStyle + [csOpaque];  // reduces flicker

  FPic := TPicture.Create;
  FPic.Assign(nil);

  FBitmap := TBitmap.Create;//TDIBUltra.Create(Screen.Width, Screen.Height, dupf16, nil);
//  FBitmap.GDIStyle := False;
  FBitmap.PixelFormat := pf16bit;
  FBitmap.Width := Width;
  FBitmap.Height := Height;

  UndoList := TList.Create;
  FUndoCount := 0;
  FTimerClock := TRXTimer.Create(Self);
  FTimeLimit := 300;                        // 5 mins for each side
  FTimerClock.OnTimer := UpdateGameTime;

  FBackgroundC := clBtnFace;
  FHighlightColour := clYellow;
  FHighlightEnemyColour := clRed;
  FHighlightCaptureColour := clLime;
  FStartDragColour := clYellow;
  FValidMoveDragColour := clGreen;
  FWhiteC := clSilver;
  FBlackC := clGray;
  FGridLineColour := clBlack;

  FHighlightSquare := TList.Create;

  Align := alClient;
  FDrawLines := True;
  FShowHints := True;
  FStretch := True;
  FStretchPic := True;
  FTurn := 1;

  FGridlineWidth := 1;
  FHighlightWidth := 2;

  FShowSquareHighlights := True;
  FSquaresHighlighted := TBits.Create;
  FSquaresHighlighted.Size := 64;

  FPiecesInSquares := TBits.Create;
  FPiecesInSquares.Size := 64;

  FHighlightStartSquare := True;
  FPicChanged := True;
  FPositionDropChanged := False;

  FSquareSize := Min(Width,Height) shr 3; // div 8
//if Width > Height then FSquareSize := Height shr 3 else FSquareSize := Width shr 3;

  FillChar(Board, sizeof(Board), 0);
  ResetBoard;
end;

destructor TChessboard.Destroy;
begin
  FTimerClock.Enabled := False;
  FTimerClock.Free;

  ClearPieces;
  FPic.Free;
  FHighlightSquare.Free;
  UndoList.Free;
  FBitmap.Free;
  FSquaresHighlighted.Free;
  FPiecesInSquares.Free;

  inherited Destroy;
end;

{ Handle WM_ERASEBKGND to stop Windows causing flickering }
procedure TChessboard.WMEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := 1; // Stop Windows erasing the background manually - will reduce flicker
end;

{ Handle WM_LBUTTONDOWN for when the user starts a left mouse button drag }
procedure TChessboard.WMBeginDrag(var Msg: TWMLButtonDown);
var
  CurrPiecePtr: TPiece;
  CurrentMousePos: TPoint;
  i: Integer;
  OldColour: TColor;   // for temp. swapping of highlight colours
begin
  if not FGameRunning then
  begin
    inherited;
    Exit;
  end;

  // Reset the old drag location (arbitrary value not on the board is used here)
  FOldDragLoc := Point(-1, -1);
  CurrPiecePtr := nil;

  // Reset all square highlighting bits in FSquaresHighlighted to false

  for i := 0 to FSquaresHighlighted.Size - 1 do
    FSquaresHighlighted[i] := False;

  // convert x & y pos to board square
  CurrentMousePos := FindNewLocation(msg.XPos, msg.YPos);

  // Detect if user is attempting to drag a piece, and set up the square
  // highlighting appropriately
  if FindPiece(CurrPiecePtr , CurrentMousePos) then
  begin
    if FShowValidMoves then
      ShowValidMoves(CurrPiecePtr);

    FDraggedPiece := CurrPiecePtr;
    FLastValidMoveLoc := FDraggedPiece.Location;
    FDragging := True;

    Screen.Cursor := crNoMove;

    Assert(InBounds(CurrPiecePtr.Location));

    if FHighlightStartSquare then
    begin
      // Highlight the dragged piece's square
      OldColour := FHighlightColour;
      FHighlightColour := FStartDragColour;

      HighlightBoardSquare(CurrPiecePtr.Location, Ord(CurrPiecePtr.Colour) = Turn);

      FHighlightColour := OldColour;
    end;
  end;
  inherited;
end;

{ Handle WM_LBUTTONUP, to determine what happens when the user lets the left
  mouse button up after dragging across the board. }
procedure TChessboard.WMStopDrag(var Msg: TWMLButtonUp);
var
  Curr,
  GetPos: TPoint;
  CurrPiecePtr: TPiece;
begin
  if not FGameRunning then
  begin
    inherited;
    Exit;
  end;
  CurrPiecePtr := nil;

  // The user has stopped dragging a piece, so clear any square highlights