Section courante

A propos

Section administrative du site

Vous vous savez du fabuleux jeux soviétique «Tetris», succès incroyable des années 1980, où il faut placer des cubes afin de faire disparaître des lignes. Voici la version que j'avais inclus dans le MonsterBook et que j'ai adapter pour QuickPascal et son unité «Crt».


A l'aide du code source Pascal suivant pour le QuickPascal, vous trouvez la réponse que vous souhaitez :

  1. Program Tetris;
  2.  
  3. Uses Crt;
  4.  
  5. Const
  6.  {Code de touche clavier renvoy,e par ReadKey}
  7.  kbNoKey=0;{Pas de touche}
  8.  kbEsc=$011B;{Escape}
  9.  kbUp=$4800;{Up}
  10.  kbLeft=$4B00;{FlSche de gauche (Left)}
  11.  kbKeypad5=$4CF0;{5 du bloc num,rique}
  12.  kbRight=$4D00;{FlSche de droite (Right)}
  13.  kbDn=$5000;{FlSche du bas (Down)}
  14.  
  15. Type
  16.  TetrisGame=Record
  17.   Mode:(tmNone,tmStart,tmPlay,tmGameOver);
  18.   Level:Byte;
  19.   Score:LongInt;
  20.   Bar,SLevel:Word;
  21.   Tbl:Array[0..20,0..9]of Boolean;
  22.   Form,Move,X,Y,Sleep:Byte;
  23.   Touch,Ok:Boolean;
  24.   SleepDelay:Byte;
  25.   FBar:Word;
  26.   UpDate:Boolean;
  27.  End;
  28.  
  29. Function  TetrisInit(Var Q:TetrisGame):Boolean;Forward;
  30. Procedure TetrisStart(Var Q:TetrisGame);Forward;
  31. Procedure TetrisRefresh(Var Q:TetrisGame);Forward;
  32. Function  TetrisPlay(Var Q:TetrisGame):Word;Forward;
  33.  
  34. Const
  35.  HomeX=15;
  36.  HomeY=2;
  37.  
  38. Procedure WaitRetrace;Begin
  39.  Delay(1000 div 60);
  40. End;
  41.  
  42. Procedure MoveRight(Var Source,Dest;Length:LongInt);Begin
  43.  Move(Source,Dest,Length);
  44. End;
  45.  
  46. Procedure TextAttr(Attr:Byte);Begin
  47.  TextColor(Attr and $F);
  48.  TextBackground(Attr shr 4);
  49. End;
  50.  
  51. Procedure MoveText(X1,Y1,X2,Y2,X3,Y3:Byte);Begin
  52.  Window(X1,Y1,X2,Y2+1);
  53.  If(Y3>Y1)Then Begin
  54.   GotoXY(1,1);
  55.   InsLine;
  56.  End
  57.   Else
  58.  Begin
  59.   GotoXY(1,1);
  60.   DelLine;
  61.  End;
  62.  Window(1,1,40,25);
  63. End;
  64.  
  65. Procedure BarSpcHor(X1,Y,X2:Byte);Begin
  66.  Window(X1,Y,X2,Y);
  67.  ClrScr;
  68.  Window(1,1,40,25);
  69. End;
  70.  
  71. Function TetrisInit(Var Q:TetrisGame):Boolean;Begin
  72.  FillChar(Q,SizeOf(Q),0);
  73.  Q.Level:=1;
  74.  Q.Mode:=tmStart;
  75.  TetrisInit:=True;
  76. End;
  77.  
  78. Procedure TetrisStart(Var Q:TetrisGame);
  79. Var
  80.  I:Byte;
  81. Begin
  82.  FillChar(Q.Tbl,SizeOf(Q.Tbl),0);
  83.  FillChar(Q.Tbl[20],SizeOf(Q.Tbl[20]),Byte(True));
  84.  Q.Score:=0;Q.Bar:=0;Q.SleepDelay:=25;Q.Level:=Q.SLevel;
  85.  For I:=0to(Q.SLevel)do If Q.SleepDelay>6Then Dec(Q.SleepDelay,2);
  86.  Q.FBar:=Q.Level shl 4;
  87.  Q.Mode:=tmStart;
  88. End;
  89.  
  90. Procedure TetrisRefresh(Var Q:TetrisGame);
  91. Var
  92.  I,J:Byte;
  93. Begin
  94.  TextBackground(1+Q.Level);
  95.  ClrScr;
  96.  GotoXY(3,2);Write('Niveau:');
  97.  GotoXY(4,3);Write(Q.Level);
  98.  GotoXY(3,5);Write('Pointage:');
  99.  GotoXY(4,6);Write('0');
  100.  GotoXY(3,8);Write('Ligne:');
  101.  GotoXY(4,9);Write(Q.Bar);
  102.  Window(HomeX,HomeY,HomeX+9,HomeY+19);
  103.  TextBackground(Black);
  104.  ClrScr;
  105.  Window(1,1,40,25);
  106.  If(Q.Mode)in[tmPlay,tmGameOver]Then Begin
  107.   For J:=0to 19do For I:=0to 9do If Q.Tbl[J,I]Then Begin
  108.    GotoXY(HomeX+I,HomeY+J);Write('þ');
  109.   End;
  110.  End;
  111. End;
  112.  
  113. Function TetrisPlay(Var Q:TetrisGame):Word;
  114. Label _Break,_BreakWhile,_Exit;
  115. Const
  116.       BlkHeight:Array[0..6,0..3]of Byte=(
  117.        (4,1,4,1), { Barre }
  118.        (2,2,2,2), { BoOte }
  119.        (3,2,3,2), { V }
  120.        (3,2,3,2), { L gauche }
  121.        (3,2,3,2), { L droite }
  122.        (3,2,3,2), { Serpent romain }
  123.        (3,2,3,2));{ Serpent arabe }
  124.       BlkLength:Array[0..6,0..3]of Byte=( {Largeur des objets:}
  125.        (1,4,1,4), { Barre }
  126.        (2,2,2,2), { BoOte }
  127.        (2,3,2,3), { V }
  128.        (2,3,2,3), { L gauche }
  129.        (2,3,2,3), { L droite }
  130.        (2,3,2,3), { Serpent romain }
  131.        (2,3,2,3));{ Serpent arabe }
  132.       BlkFormat:Array[0..6,0..3,0..3]of Record X,Y:Byte;End=(
  133.        (((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:0;Y:3)),   { þþþþ }
  134. ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:3;Y:0)),
  135. ((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:0;Y:3)),
  136. ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:3;Y:0))),
  137.        (((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),   { þþ }
  138. ((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),   { þþ }
  139. ((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),
  140. ((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1))),
  141.        (((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),   { þþþ }
  142. ((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:2;Y:1)),   { þ }
  143. ((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),
  144. ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:1;Y:1))),
  145.        (((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:1;Y:2)),
  146. ((X:0;Y:1),(X:1;Y:1),(X:2;Y:1),(X:2;Y:0)),   { þ }
  147. ((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:1;Y:2)),   { þ }
  148. ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:0;Y:1))),  { þþ }
  149.        (((X:1;Y:0),(X:1;Y:1),(X:1;Y:2),(X:0;Y:2)),
  150. ((X:0;Y:1),(X:1;Y:1),(X:2;Y:1),(X:0;Y:0)),   { þ }
  151. ((X:1;Y:0),(X:0;Y:0),(X:0;Y:1),(X:0;Y:2)),   { þ }
  152. ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:2;Y:1))),  { þþ }
  153.        (((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),
  154. ((X:1;Y:0),(X:2;Y:0),(X:0;Y:1),(X:1;Y:1)),
  155. ((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),
  156. ((X:1;Y:0),(X:2;Y:0),(X:0;Y:1),(X:1;Y:1))),
  157.        (((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),
  158. ((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:2;Y:1)),
  159. ((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),   {þþ }
  160. ((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:2;Y:1)))); { þþ }
  161. Var
  162.  I,J,H,XT:Byte;
  163.  XJ,YJ,K:Word;
  164.  Touch,Ok,NoAction:Boolean;
  165.  
  166.  Procedure PutForm(Clr:Boolean);
  167.  Var
  168.   Chr:Char;
  169.   I,Attr,X,Y:Byte;
  170.  Begin
  171.   X:=HomeX+Q.X;
  172.   Y:=HomeY+Q.Y;
  173.   If(Clr)Then Begin
  174.    Chr:=' ';Attr:=7;
  175.   End
  176.    Else
  177.   Begin
  178.    Chr:='þ';Attr:=$71+Q.Form;
  179.   End;
  180.   For I:=0to 3do Begin
  181.    GotoXY(HomeX+Q.X+BlkFormat[Q.Form,Q.Move,I].X,
  182.     HomeY+Q.Y+BlkFormat[Q.Form,Q.Move,I].Y);
  183.    TextAttr(Attr);
  184.    Write(Chr);
  185.    TextAttr(7);
  186.   End;
  187.  End;
  188.  
  189.  Procedure Init;Begin
  190.   Q.Form:=Random(6);
  191.   If Q.Form=5Then Inc(Q.Form,Random(2));
  192.   Q.X:=5;Q.Y:=0;
  193.   Q.Move:=0;Q.Sleep:=0;
  194.   PutForm(False);
  195.  End;
  196.  
  197.  Function UpDateData:Boolean;
  198.  Var
  199.   H,I,J,JK:Byte;
  200.   Bonus:Byte;
  201.   LnChk:Boolean;
  202.  Begin
  203.   UpDateData:=True;Q.Sleep:=0;
  204.   PutForm(False);
  205.   Touch:=False;Ok:=False;
  206.   PutForm(True);
  207.   Inc(Q.Y);
  208.   For I:=0to 3do Begin
  209.    Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,Q.Move,I].Y,Q.X+BlkFormat[Q.Form,Q.Move,I].X];
  210.   End;
  211.   If(Touch)Then Dec(Q.Y);
  212.   PutForm(False);
  213.   If(Touch)Then Begin
  214.    While(Q.Sleep>Q.SleepDelay)do Dec(Q.Sleep);
  215.    Q.Sleep:=0;Ok:=True;
  216.    For I:=0to 3do Q.Tbl[Q.Y+BlkFormat[Q.Form,Q.Move,I].Y,Q.X+BlkFormat[Q.Form,Q.Move,I].X]:=True;
  217.    If Q.Level>7Then Begin
  218.     Inc(Q.Score,LongInt(5)*Q.Level);
  219.     GotoXY(4,6);Write(Q.Score);
  220.    End;
  221.    Bonus:=0;
  222.    For J:=0to 19do Begin
  223.     Touch:=True;
  224.     For I:=0to 9do Touch:=Touch and Q.Tbl[J,I];
  225.     If(Touch)Then Inc(Bonus);
  226.    End;
  227.    If Bonus>0Then Dec(Bonus);
  228.    Touch:=False;
  229.    For JK:=0to 7do Begin
  230.     For J:=0to 19do Begin
  231.      LnChk:=True;
  232.      For I:=0to 9do LnChk:=LnChk and Q.Tbl[J,I];
  233.      If(LnChk)Then Begin
  234.       If Not(Touch)Then Begin
  235.        Touch:=True;
  236.       End;
  237.       If JK and 1=0Then TextAttr($FF)
  238.    Else TextAttr(7);
  239.       BarSpcHor(HomeX,HomeY+J,HomeX+9);
  240.      End;
  241.     End;
  242.     WaitRetrace;WaitRetrace;WaitRetrace;
  243.    End;
  244.    For J:=0to 19do Begin
  245.     Touch:=True;
  246.     For I:=0to 9do Touch:=Touch and Q.Tbl[J,I];
  247.     If(Touch)Then Begin
  248.      MoveRight(Q.Tbl[0,0],Q.Tbl[1,0],10*J);
  249.      FillChar(Q.Tbl[0,0],10,0);
  250.      MoveText(HomeX,HomeY,HomeX+9,HomeY+J-1,HomeX,HomeY+1);
  251.      Inc(Q.Score,LongInt(5)+(Bonus*4)*(Q.Level+1)+10*Q.Level); Inc(Q.Bar);
  252.      GotoXY(4,6);Write(Q.Score);
  253.      GotoXY(4,9);Write(Q.Bar);
  254.      I:=(Q.Bar+Q.FBar)shr 4;
  255.      If(Q.Level<>I)Then Begin
  256.       Q.Level:=I;
  257.       GotoXY(4,3);Write(Q.Level+1);
  258.       If Q.SleepDelay>6Then Dec(Q.SleepDelay,2);
  259.      End;
  260.     End;
  261.    End;
  262.    If Q.Y<=1Then Begin
  263.     UpDateData:=False;
  264.     Exit;
  265.    End;
  266.    Init;
  267.   End;
  268.  End;
  269.  
  270.  Function GameOver:Word;Begin
  271.   GotoXY(10,7);Write('Partie Terminer');
  272.   If(Q.UpDate)Then Begin
  273.    Q.UpDate:=False;
  274.   End;
  275.   GameOver:=kbEsc;
  276.  End;
  277.  
  278. Begin
  279.  TextMode(CO40);
  280.  TetrisRefresh(Q);
  281.  K:=0;
  282.  Repeat
  283.   Case(Q.Mode)of
  284.    tmStart:Begin
  285.     TetrisStart(Q);
  286.     TetrisRefresh(Q);
  287.     Init;
  288.     Q.Mode:=tmPlay;Q.UpDate:=True;
  289.    End;
  290.    tmPlay:Begin
  291.     Repeat
  292.     Begin
  293.      Repeat
  294.       If(Q.Sleep>Q.SleepDelay)Then If Not(UpDateData)Then Begin
  295.        Q.Mode:=tmGameOver;
  296.        Goto _Exit;
  297.       End;
  298.       WaitRetrace;
  299.       Inc(Q.Sleep);
  300.      Until KeyPressed;
  301.      K:=Byte(ReadKey);
  302.      If K=0Then K:=K or (Byte(ReadKey)shl 8);
  303.     End;
  304.     If Chr(K)='2'Then K:=kbDn;
  305.     If Chr(K)='4'Then K:=kbLeft;
  306.     If Chr(K)='6'Then K:=kbRight;
  307.     NoAction:=False;
  308.     Case(K)of
  309.      kbLeft:If Q.X>0Then Begin
  310.       Touch:=False;
  311.       For I:=0to 3do Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,Q.Move,I].Y,Q.X+BlkFormat[Q.Form,Q.Move,I].X-1];
  312.       If Not(Touch)Then Begin
  313.        PutForm(True);
  314.        Dec(Q.X);
  315.        PutForm(False);
  316.       End;
  317.      End;
  318.      kbRight:If Q.X+BlkLength[Q.Form,Q.Move]-1<9Then Begin
  319.       Touch:=False;
  320.       For I:=0to 3do Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,Q.Move,I].Y,Q.X+BlkFormat[Q.Form,Q.Move,I].X+1];
  321.       If Not(Touch)Then Begin
  322.        PutForm(True);
  323.        Inc(Q.X);
  324.        PutForm(False);
  325.       End;
  326.      End;
  327.      kbDn:While(True)do Begin
  328.       If Not(UpDateData)Then Begin
  329.        Q.Mode:=tmGameOver;
  330.        Goto _Exit;
  331.       End;
  332.       If(Ok)Then Goto _BreakWhile;
  333.      End;
  334.      Else NoAction:=True;
  335.     End;
  336. _BreakWhile:
  337.     If(NoAction)Then Begin
  338.      If(K=kbKeyPad5)or(Char(K)in[' ','5'])Then Begin
  339.       Touch:=False;
  340.       For I:=0to 3do Begin
  341.        XT:=Q.X+BlkFormat[Q.Form,(Q.Move+1)and 3,I].X; Touch:=Touch or(XT>9);
  342.        Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,(Q.Move+1)and 3,I].Y,XT];
  343.       End;
  344.       If Not(Touch)Then Begin
  345.        PutForm(True);
  346.        Q.Move:=(Q.Move+1)and 3;
  347.        PutForm(False)
  348.       End
  349.        Else
  350.       Begin
  351.        Touch:=False;
  352.        For I:=0to 3do Begin
  353. XT:=Q.X;
  354. If XT>0Then Dec(XT);
  355. Inc(XT,BlkFormat[Q.Form,(Q.Move+1)and 3,I].X); Touch:=Touch or(XT>9);
  356. Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,(Q.Move+1)and 3,I].Y,XT];
  357.        End;
  358.        If Not(Touch)Then Begin
  359. PutForm(True);
  360. Dec(Q.X); Q.Move:=(Q.Move+1)and 3;
  361. PutForm(False);
  362.        End;
  363.       End;
  364.      End
  365.       Else
  366.      Goto _Break;
  367.     End;
  368.    Until(K=kbEsc)or(Chr(K)='Q');
  369. _Break:
  370.    End;
  371.    tmGameOver:K:=GameOver;
  372.   End;
  373. _Exit:
  374.  Until K<>0;
  375.  TetrisPlay:=K;
  376. End;
  377.  
  378. Var
  379.  Game:TetrisGame;
  380.  K:Word;
  381.  
  382. BEGIN
  383.  If TetrisInit(Game)Then Begin
  384.   K:=TetrisPlay(Game);
  385.  End;
  386. END.

Code source

Voici le code source du jeu sur GitHub :

Lien Langage de programmation Projet
https://github.com/gladir/quickpascal_tetris/blob/main/TETRIS.PAS Quick Pascal quickpascal_tetris


Dernière mise à jour : Dimanche, le 4 mai 2014