t_tetris.pas

delphi写的俄罗斯方块

unit T_TETRIS;

{
                                   \\\\\/////
                                   /  _   _  \
                                  (| (.) (.) |)
 _______________________________.OOOo__( )__oOOO.______________________________
|                                                                              |
|                               This is my Tcomponent                          |
|                                    Ciao Marco                                |
|                              Email [e-mail]                         |
|                                                                              |
| DATA:      INIZIO:    FINE:      LAVORO:                                     |
|                                                                              |
| 12-07-97,  19:01:38,  21:31:09,  FATTO QUASI TUTTO.                          |
| 13-07-97,  03:39:42,  04:13:11,  ULTIMI DETTAGLI.                            |
| 16-07-97,  14:10:49,  16:05:18,  UN PO' DI OPZIONI NON FANNO MAI MALE...     |
| 30-07-97,  12:20:33,  AGGIUNTO LA FUNZIONE GET_FREE_LINES (10 MINUTI...)     |
| 11-08-97,  10:46:38,  12:08:54,  AGGIUNTO UN PO' DI PEZZI NUOVI.             |
| 25-08-97,  00:12:06,  01:14:23,  AGGIUNTO LA FORM PREVIEW.                   |
|                                                                              |
|_______________________________.oooO__________________________________________|
                                (   )        Oooo.
                                 \ (         (   )
                                  \_)         ) /
                                             (_/
}
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;{,Winprocs,
  wintypes,extctrls;                                                        }

CONST
 TETRIS_COLUMNS=9; //DIMENSIONI DEL CAMPO DI GIOCO
 TETRIS_LINES=20;
 COLORI:ARRAY[1..14] OF TCOLOR = (CLMAROON,CLGREEN,CLOLIVE,CLNAVY,
                                CLPURPLE,CLTEAL,CLGRAY,CLSILVER,CLRED,
                                CLLIME,CLYELLOW,CLBLUE,CLFUCHSIA,
                                CLAQUA);
 type
  TBlockType = (btNormal, btRound, btButton);
  TMultiShapeType=(msRectangle,msRoundRect,msDiamond,msEllipse,msTriangle);
  PEZZO=ARRAY[0..3,0..3] OF INTEGER;
  TTETRIS = class(TGraphicControl)
  private
   { Private declarations }
   P_CAPT:TCAPTION;
   F_PREW:TFORM;   //FORM PREW
   P_SIZE:INTEGER; //DIMENSIONI PREW
   Piece:ARRAY[1..2] OF integer;
   N_TYPE:INTEGER; //NUMERO DI PEZZI
//   fBitmap:    TBitmap;
   SNP:BOOLEAN;    //VISUALIZZA IL PROSSIMO PEZZO
   SIL:BOOLEAN;    //WISUALIZZA IL CONTORNO DEL PEZZO
   SFC:BOOLEAN;    //VISUALIZZA IL COLORE DI RIEMPIMENTO
   P_COUNT,        //CONTATORE PEZZI
   SIZEX,SIZEY,
   SCR_N,          //TIPO SCHERMO
   DELETED_L,      //ULTIME RIGHE CANCELLATE. <0 PER NUOVO PEZZ0
   SQX:INTEGER;
   CX,CY:INTEGER;  //POSIZIONE DEL PEZZO
   Vet:array[0..TETRIS_COLUMNS,0..TETRIS_LINES] of TCOLOR;
   PEZ:PEZZO;
   NULL_COLOR:TCOLOR;
   BLOCK_TYPE: TBLOCKTYPE;
   FUNCTION  CAN_MOVE(CONST DOVE,X,Y:INTEGER):BOOLEAN;
   FUNCTION  POSI(KX,KY,JX,JY:INTEGER):BOOLEAN;
   FUNCTION  FULL_LINES(DA:INTEGER):INTEGER;
   PROCEDURE P(X,Y:INTEGER;C:TCOLOR);
   procedure MakeObj(const N:integer);
   PROCEDURE SET_SQUARE_DIM(VALUE:INTEGER);
   PROCEDURE SET_P_SIZE(S:INTEGER);
   PROCEDURE DISEGNA_PEZZO(CONST X,Y:INTEGER;CONST VEDI:BOOLEAN);
   PROCEDURE SALVA_PEZZO(KX,KY:INTEGER);
   PROCEDURE RUOTA_PEZZO(CONST N,X,Y:INTEGER;VAR PEZZ:PEZZO);
   PROCEDURE SET_NEXT_PIECE(VALUE:INTEGER);
   PROCEDURE SET_BK_COLOR(VALUE:TCOLOR);
   PROCEDURE SHOW_NEXT;
   PROCEDURE NOT_PIECE_COUNT(VALUE:INTEGER);
   PROCEDURE NOT_DELETED_COUNT(VALUE:INTEGER);
//   procedure fSetBitmap(Value: TBitmap);
   PROCEDURE SET_SIL(VALUE:BOOLEAN);
   PROCEDURE SET_SFC(VALUE:BOOLEAN);
   PROCEDURE SET_SCREEN(VALUE:INTEGER);
   PROCEDURE MAKE_SCREEN;
   PROCEDURE QUADRATO(X,Y:INTEGER;C:TCOLOR);
   PROCEDURE SET_SNP(VALUE:BOOLEAN);
   PROCEDURE SET_N_TYPE(VALUE:INTEGER);
   PROCEDURE SET_CAPTION(VALUE:TCAPTION);
   PROCEDURE SET_BLOCK_TYPE(VALUE: TBLOCKTYPE);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
   Constructor Create(AOwner:TComponent); OVERRIDE;
//   destructor Destroy; override;
   PROCEDURE NEW_GAME; // INIZIALIZZA IL GIOCO
   //RUNTIME PER MUOVERE IL PEZZO
   FUNCTION MOVE_DOWN:INTEGER;
   FUNCTION SEND_BOTTOM:INTEGER;
   FUNCTION MOVE_LEFT:BOOLEAN;
   FUNCTION MOVE_RIGHT:BOOLEAN;
   FUNCTION GET_FREE_LINES(SEE:BOOLEAN):INTEGER;
   PROCEDURE ROTATE_LEFT;
   PROCEDURE ROTATE_RIGHT;
   //RUNTIME PER MODIFICARE LE IMPOSTAZIONI DELLO SCHERMO
   PROCEDURE SET_PIECE(X,Y:INTEGER;C:TCOLOR);
   PROCEDURE INSERT_LINE(X:INTEGER;C:TCOLOR);
   PROCEDURE MOVE_PREVIEW(X,Y:INTEGER);
  published
    { Published declarations }
   PROPERTY NumberOfPieces:INTEGER READ P_COUNT WRITE NOT_PIECE_COUNT;
   PROPERTY NextPiece:INTEGER READ PIECE[2] WRITE SET_NEXT_PIECE;
   PROPERTY LastDeletedLine:INTEGER READ DELETED_L WRITE NOT_DELETED_COUNT;
   PROPERTY BackGroundColor:TCOLOR READ NULL_COLOR WRITE SET_BK_COLOR;
   PROPERTY ScreenNumber:INTEGER READ SCR_N WRITE SET_SCREEN;
   PROPERTY SquareDimension:INTEGER READ SQX WRITE SET_SQUARE_DIM;
   PROPERTY ShowBorderColor:BOOLEAN READ SIL WRITE SET_SIL;
   PROPERTY ShowFillColor:BOOLEAN READ SFC WRITE SET_SFC;
   PROPERTY ShowNextpiece:BOOLEAN READ SNP WRITE SET_SNP;
   PROPERTY NumberOfType:INTEGER READ N_TYPE WRITE SET_N_TYPE;
   PROPERTY PreviewSize:INTEGER READ P_SIZE WRITE SET_P_SIZE;
   PROPERTY PreviewCaption:TCAPTION READ P_CAPT WRITE SET_CAPTION;
   PROPERTY Blocktype: TBLOCKTYPE READ BLOCK_TYPE WRITE SET_BLOCK_TYPE;
//   property BackBitmap: TBitmap read fBitmap write fSetBitmap;
  end;

procedure Register;

implementation


PROCEDURE TTETRIS.SET_SIL(VALUE:BOOLEAN);
 BEGIN
  SIL:=VALUE;
  IF NOT SIL THEN
   SFC:=TRUE;
  PAINT;
 END;

PROCEDURE TTETRIS.SET_CAPTION(VALUE:TCAPTION);
 BEGIN
  P_CAPT:=VALUE;
  F_PREW.CAPTION:=VALUE;
 END;

PROCEDURE TTETRIS.SET_BLOCK_TYPE(VALUE: TBLOCKTYPE);
BEGIN
  BLOCK_TYPE:=VALUE;
  PAINT;
END;

PROCEDURE TTETRIS.MOVE_PREVIEW(X,Y:INTEGER);
 BEGIN
  F_PREW.TOP:=Y;
  F_PREW.LEFT:=X;
 END;
                            {
procedure TTETRIS.fSetBitmap(Value: TBitmap);
Begin
    FBitmap.Assign(Value);
    Invalidate;
End;
                           }
PROCEDURE TTETRIS.SHOW_NEXT;
 VAR
  EX,EY,
  A,B:INTEGER;
 BEGIN
  F_PREW.Canvas.Pen.Color:=NULL_COLOR;
  F_PREW.Canvas.Rectangle(0,0,F_PREW.CLIENTWIDTH,F_PREW.CLIENTHEIGHT);
  IF NOT SFC THEN
   F_PREW.Canvas.BRUSH.Color:=NULL_COLOR;
  FOR A:=0 TO 3 DO
   FOR B:=0 TO 3 DO
    BEGIN
     IF SIL THEN
      F_PREW.Canvas.Pen.Color:=PEZ[A,B];
     IF SFC THEN
      F_PREW.Canvas.BRUSH.Color:=PEZ[A,B];
     EX:=A*P_SIZE;
     EY:=B*P_SIZE;
     IF PEZ[A,B]<>NULL_COLOR THEN
      F_PREW.Canvas.Rectangle(EX,EY,EX+P_SIZE,EY+P_SIZE);
    END;
 END;

PROCEDURE TTETRIS.SET_SNP(VALUE:BOOLEAN);
 BEGIN
  SNP:=VALUE;
  IF SNP THEN
   F_PREW.SHOW
  ELSE
   F_PREW.CLOSE;
 END;

PROCEDURE TTETRIS.SET_P_SIZE(S:INTEGER);
 BEGIN
  IF (S>2) AND (S<>P_SIZE) THEN
   BEGIN
    P_SIZE:=S;
    F_PREW.CLIENTWIDTH:=4*S;
    F_PREW.CLIENTHEIGHT:=4*S;
   END;
 END;

PROCEDURE TTETRIS.SET_SFC(VALUE:BOOLEAN);
 BEGIN
  SFC:=VALUE;
  IF NOT SFC THEN
   SIL:=TRUE;
  INVALIDATE;
 END;

PROCEDURE TTETRIS.NOT_PIECE_COUNT(VALUE:INTEGER);
 BEGIN
  IF VALUE<>P_COUNT THEN
   SHOWMESSAGE('This is a Read-Only Property...');
 END;

PROCEDURE TTETRIS.SET_SQUARE_DIM(VALUE:INTEGER);
 BEGIN
  SQX:=VALUE;
  HEIGHT:=SQX*TETRIS_LINES;
  WIDTH:=SQX*TETRIS_COLUMNS;
 END;

PROCEDURE TTETRIS.NOT_DELETED_COUNT(VALUE:INTEGER);
 BEGIN
  IF VALUE<>DELETED_L THEN
   SHOWMESSAGE('This is a Read-Only Property...');
 END;

PROCEDURE TTETRIS.SET_BK_COLOR(VALUE:TCOLOR);
 VAR
  A,B:INTEGER;
 BEGIN
  IF VALUE<>NULL_COLOR THEN
   BEGIN
    FOR A:=0 TO TETRIS_COLUMNS DO
     FOR B:=0 TO TETRIS_LINES DO
      IF VET[A,B]=NULL_COLOR THEN
       BEGIN
        VET[A,B]:=VALUE;
        QUADRATO(A,B,VET[A,B]);
       END;
    FOR A:=0 TO 3 DO
     FOR B:=0 TO 3 DO
      IF PEZ[A,B]=NULL_COLOR THEN
       PEZ[A,B]:=VALUE;
    NULL_COLOR:=VALUE;
    PAINT;
    //INVALIDATE;
   END;
 END;


PROCEDURE TTETRIS.QUADRATO(X,Y:INTEGER;C:TColor);
 Var
  X1,Y1,X2,Y2: Integer;
 BEGIN
  IF NOT SIL THEN
  Canvas.Pen.Color:=NULL_COLOR
  ELSE
   Canvas.Pen.Color:=C;
  IF NOT SFC THEN
   Canvas.BRUSH.Color:=NULL_COLOR
  ELSE
   Canvas.BRUSH.Color:=C;
  X1:=X*SIZEX;
  Y1:=Y*SIZEY;
  X2:=(X+1)*SIZEX;
  Y2:=(Y+1)*SIZEY;
  IF C=NULL_COLOR THEN
   Canvas.Rectangle(X1,Y1,X2,Y2)
  ELSE
   CASE BLOCK_TYPE OF
     btNormal:Canvas.Rectangle(X1,Y1,X2,Y2);
     btRound:Canvas.Ellipse(X1,Y1,X2,Y2);
     btButton:With Canvas do
               begin
                Rectangle(X1+1,Y1+1,X2-1,Y2-1);
                Pen.Color:=clBtnHighlight;
                MoveTo(X1,Y2-1);
                LineTo(X1,Y1);
                LineTo(X2-1,Y1);
                Pen.Color:=clBtnShadow;
                LineTo(X2-1,Y2-1);
                LineTo(X1,Y2-1);
               end;
   End; // <--Case BLOCK_TYPE of
END; // QUADRATO(X,Y)

//AGGIUNGE UN QUADRETTO DI COLORE C NELLA POSIZIONE X,Y.
//SE Y=-1 VIENE AGGIUNTO NELL'ULTIMA POSIZIONE LIBERA PARTENDO DALL'ALTO.
PROCEDURE TTETRIS.SET_PIECE(X,Y:INTEGER;C:TCOLOR);
 VAR
  Q:INTEGER;
 BEGIN
  IF (X IN [0..TETRIS_COLUMNS]) AND (Y+1 IN [0..TETRIS_LINES+1]) THEN
   BEGIN
    Q:=Y;
    IF Q=-1 THEN
     REPEAT
      INC(Q);
     UNTIL (Q=TETRIS_LINES) OR (VET[X,Q+1]<>NULL_COLOR);
     VET[X,Q]:=C;
     QUADRATO(X,Q,VET[X,Q]);
     DELETED_L:=FULL_LINES(Q);
   END
  ELSE
   //SHOWMESSAGE('Value out of range...');
 END;

PROCEDURE TTETRIS.INSERT_LINE(X:INTEGER;C:TCOLOR);
 VAR
  A,B:INTEGER;
 BEGIN
  IF (X IN [0..TETRIS_COLUMNS]) THEN
   BEGIN
    IF C<>NULL_COLOR THEN
     BEGIN
      //TRASLA TUTTO IN ALTO
      FOR A:=0 TO TETRIS_COLUMNS DO
       FOR B:=1 TO TETRIS_LINES DO
        VET[A,B-1]:=VET[A,B];
      //INSERISCE LA LINEA
      FOR A:=0 TO TETRIS_COLUMNS DO
       IF A=X THEN
        VET[A,TETRIS_LINES]:=NULL_COLOR
       ELSE
        VET[A,TETRIS_LINES]:=C;
      PAINT;
     END
    ELSE
     SHOWMESSAGE('这种颜色必须与背景色不同...');
   END
  ELSE
   //SHOWMESSAGE('Value out of range...');
 END;

PROCEDURE TTETRIS.SET_NEXT_PIECE(VALUE:INTEGER);
 BEGIN
  IF VALUE IN [1..15] THEN
   BEGIN
    IF PIECE[2] <> VALUE THEN
     BEGIN
      PIECE[2]:=VALUE;
      IF SNP THEN
       BEGIN
        MAKEOBJ(PIECE[2]);
        SHOW_NEXT;
       END;
      MAKEOBJ(PIECE[1]);
     END;
   END
  ELSE
   SHOWMESSAGE('There is only 15 [1..15] kind of pieces...'+inttostr(value));
 END;

 PROCEDURE TTETRIS.SET_N_TYPE(VALUE:INTEGER);
 BEGIN
  IF VALUE IN [8..15] THEN
   N_TYPE:=VALUE
  ELSE
   //SHOWMESSAGE('Value out of range...');
 END;

//TRUE SE IL PEZZO VIENE SPOSTATO
FUNCTION TTETRIS.MOVE_LEFT:BOOLEAN;
 VAR
  K:BOOLEAN;
 BEGIN
  K:=CAN_MOVE(2,CX,CY);
  IF K THEN
   BEGIN
    DISEGNA_PEZZO(CX,CY,FALSE);
    CX:=CX-1;
    DISEGNA_PEZZO(CX,CY,TRUE);
   END;
  MOVE_LEFT:=K;
 END;

//TRUE SE IL PEZZO VIENE SPOSTATO
FUNCTION TTETRIS.GET_FREE_LINES(SEE:BOOLEAN):INTEGER;
 VAR
  J:BOOLEAN;
  A,B,K:INTEGER;
 BEGIN
  K:=-1;
  FOR A:=0 TO TETRIS_LINES DO
   BEGIN
    J:=TRUE;
    FOR B:=0 TO TETRIS_COLUMNS DO
     J:=J AND (VET[B,A]=NULL_COLOR);
    IF J THEN // QUESTA LINEA E' VUOTA
     BEGIN
      K:=A;
      IF SEE THEN
       BEGIN
        Canvas.Pen.Color:=CLWHITE;
        Canvas.BRUSH.Color:=NULL_COLOR;//CLBLACK;
        Canvas.Rectangle(0,A*SIZEY,TETRIS_COLUMNS*SIZEX+SIZEX,A*SIZEY+SIZEY);
       END;
     END;
   END;
  GET_FREE_LINES:=K+1;//+1 PERCHE' PARTE DA 0
 END;

//TRUE SE IL PEZZO VIENE SPOSTATO
FUNCTION TTETRIS.MOVE_RIGHT:BOOLEAN;
 VAR
  K:BOOLEAN;
 BEGIN
  K:=CAN_MOVE(1,CX,CY);
  IF K THEN
   BEGIN
    DISEGNA_PEZZO(CX,CY,FALSE);
    CX:=CX+1;
    DISEGNA_PEZZO(CX,CY,TRUE);
   END;
  MOVE_RIGHT:=K;
 END;

PROCEDURE TTETRIS.ROTATE_LEFT;
 BEGIN
  DISEGNA_PEZZO(CX,CY,FALSE);
  RUOTA_PEZZO(1,CX,CY,PEZ);
  DISEGNA_PEZZO(CX,CY,TRUE);
 END;

PROCEDURE TTETRIS.ROTATE_RIGHT;
 BEGIN
  DISEGNA_PEZZO(CX,CY,FALSE);
  RUOTA_PEZZO(2,CX,CY,PEZ);
  DISEGNA_PEZZO(CX,CY,TRUE);
 END;

FUNCTION TTETRIS.SEND_BOTTOM:INTEGER;
 VAR
  E:INTEGER;
 begin
  E:=0;
  DISEGNA_PEZZO(CX,CY,FALSE);
  WHILE CAN_MOVE(0,CX,CY) DO
   BEGIN
    INC(E);
    CY:=CY+1; //ABBASSA IL PEZZO
   END;
  DISEGNA_PEZZO(CX,CY,TRUE);
  SEND_BOTTOM:=E;
 END;