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 disparaitre des lignes. Voici la version que j'avais inclus dans le MonsterBook et que j'ai adapter pour Virtual Pascal et son unité «Crt».

A l'aide du code source Pascal suivant pour le Virtual Pascal, 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(Const Source;Var 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. End;
  76.  
  77. Procedure TetrisStart(Var Q:TetrisGame);
  78. Var
  79.  I:Byte;
  80. Begin
  81.  FillChar(Q.Tbl,SizeOf(Q.Tbl),0);
  82.  FillChar(Q.Tbl[20],SizeOf(Q.Tbl[20]),Byte(True));
  83.  Q.Score:=0;Q.Bar:=0;Q.SleepDelay:=25;Q.Level:=Q.SLevel;
  84.  For I:=0to(Q.SLevel)do If Q.SleepDelay>6Then Dec(Q.SleepDelay,2);
  85.  Q.FBar:=Q.Level shl 4;
  86.  Q.Mode:=tmStart;
  87. End;
  88.  
  89. Procedure TetrisRefresh(Var Q:TetrisGame);
  90. Var
  91.  I,J:Byte;
  92. Begin
  93.  TextBackground(1+Q.Level);
  94.  ClrScr;
  95.  GotoXY(3,2);Write('Niveau:');
  96.  GotoXY(4,3);Write(Q.Level);
  97.  GotoXY(3,5);Write('Pointage:');
  98.  GotoXY(4,6);Write('0');
  99.  GotoXY(3,8);Write('Ligne:');
  100.  GotoXY(4,9);Write(Q.Bar);
  101.  Window(HomeX,HomeY,HomeX+9,HomeY+19);
  102.  TextBackground(Black);
  103.  ClrScr;
  104.  Window(1,1,40,25);
  105.  If(Q.Mode)in[tmPlay,tmGameOver]Then Begin
  106.   For J:=0to 19do For I:=0to 9do If Q.Tbl[J,I]Then Begin
  107.    GotoXY(HomeX+I,HomeY+J);Write('þ');
  108.   End;
  109.  End;
  110. End;
  111.  
  112. Function TetrisPlay(Var Q:TetrisGame):Word;Label _Exit;Const
  113.       BlkHeight:Array[0..6,0..3]of Byte=(
  114.        (4,1,4,1), { Barre }
  115.        (2,2,2,2), { BoOte }
  116.        (3,2,3,2), { V }
  117.        (3,2,3,2), { L gauche }
  118.        (3,2,3,2), { L droite }
  119.        (3,2,3,2), { Serpent romain }
  120.        (3,2,3,2));{ Serpent arabe }
  121.       BlkLength:Array[0..6,0..3]of Byte=( {Largeur des objets:}
  122.        (1,4,1,4), { Barre }
  123.        (2,2,2,2), { BoOte }
  124.        (2,3,2,3), { V }
  125.        (2,3,2,3), { L gauche }
  126.        (2,3,2,3), { L droite }
  127.        (2,3,2,3), { Serpent romain }
  128.        (2,3,2,3));{ Serpent arabe }
  129.       BlkFormat:Array[0..6,0..3,0..3]of Record X,Y:Byte;End=(
  130.        (((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:0;Y:3)),   { þþþþ }
  131.         ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:3;Y:0)),
  132.         ((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:0;Y:3)),
  133.         ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:3;Y:0))),
  134.        (((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),   { þþ }
  135.         ((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),   { þþ }
  136.         ((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),
  137.         ((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1))),
  138.        (((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),   { þþþ }
  139.         ((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:2;Y:1)),   { þ }
  140.         ((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),
  141.         ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:1;Y:1))),
  142.        (((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:1;Y:2)),
  143.         ((X:0;Y:1),(X:1;Y:1),(X:2;Y:1),(X:2;Y:0)),   { þ }
  144.         ((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:1;Y:2)),   { þ }
  145.         ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:0;Y:1))),  { þþ }
  146.        (((X:1;Y:0),(X:1;Y:1),(X:1;Y:2),(X:0;Y:2)),
  147.         ((X:0;Y:1),(X:1;Y:1),(X:2;Y:1),(X:0;Y:0)),   { þ }
  148.         ((X:1;Y:0),(X:0;Y:0),(X:0;Y:1),(X:0;Y:2)),   { þ }
  149.         ((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:2;Y:1))),  { þþ }
  150.        (((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),
  151.         ((X:1;Y:0),(X:2;Y:0),(X:0;Y:1),(X:1;Y:1)),
  152.         ((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),
  153.         ((X:1;Y:0),(X:2;Y:0),(X:0;Y:1),(X:1;Y:1))),
  154.        (((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),
  155.         ((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:2;Y:1)),
  156.         ((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),   {þþ }
  157.         ((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:2;Y:1)))); { þþ }
  158. Var
  159.  I,J,H,XT:Byte;
  160.  XJ,YJ,K:Word;
  161.  Touch,Ok,NoAction:Boolean;
  162.  
  163.  Procedure PutForm(Clr:Boolean);
  164.  Var
  165.   Chr:Char;
  166.   I,Attr,X,Y:Byte;
  167.  Begin
  168.   X:=HomeX+Q.X;
  169.   Y:=HomeY+Q.Y;
  170.   If(Clr)Then Begin
  171.    Chr:=' ';Attr:=7;
  172.   End
  173.    Else
  174.   Begin
  175.    Chr:='þ';Attr:=$71+Q.Form;
  176.   End;
  177.   For I:=0to 3do Begin
  178.    GotoXY(HomeX+Q.X+BlkFormat[Q.Form,Q.Move,I].X,
  179.                             HomeY+Q.Y+BlkFormat[Q.Form,Q.Move,I].Y);
  180.    TextAttr(Attr);
  181.    Write(Chr);
  182.    TextAttr(7);
  183.   End;
  184.  End;
  185.  
  186.  Procedure Init;Begin
  187.   Q.Form:=Random(6);
  188.   If Q.Form=5Then Inc(Q.Form,Random(2));
  189.   Q.X:=5;Q.Y:=0;
  190.   Q.Move:=0;Q.Sleep:=0;
  191.   PutForm(False);
  192.  End;
  193.  
  194.  Function UpDateData:Boolean;
  195.  Var
  196.   H,I,J,JK:Byte;
  197.   Bonus:Byte;
  198.   LnChk:Boolean;
  199.  Begin
  200.   UpDateData:=True;Q.Sleep:=0;
  201.   PutForm(False);
  202.   Touch:=False;Ok:=False;
  203.   PutForm(True);
  204.   Inc(Q.Y);
  205.   For I:=0to 3do Begin
  206.    Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,Q.Move,I].Y,Q.X+BlkFormat[Q.Form,Q.Move,I].X];
  207.   End;
  208.   If(Touch)Then Dec(Q.Y);
  209.   PutForm(False);
  210.   If(Touch)Then Begin
  211.    While(Q.Sleep>Q.SleepDelay)do Dec(Q.Sleep);
  212.    Q.Sleep:=0;Ok:=True;
  213.    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;
  214.    If Q.Level>7Then Begin
  215.     Inc(Q.Score,LongInt(5)*Q.Level);
  216.     GotoXY(4,6);Write(Q.Score);
  217.    End;
  218.    Bonus:=0;
  219.    For J:=0to 19do Begin
  220.     Touch:=True;
  221.     For I:=0to 9do Touch:=Touch and Q.Tbl[J,I];
  222.     If(Touch)Then Inc(Bonus);
  223.    End;
  224.    If Bonus>0Then Dec(Bonus);
  225.    Touch:=False;
  226.    For JK:=0to 7do Begin
  227.     For J:=0to 19do Begin
  228.      LnChk:=True;
  229.      For I:=0to 9do LnChk:=LnChk and Q.Tbl[J,I];
  230.      If(LnChk)Then Begin
  231.       If Not(Touch)Then Begin
  232.        Touch:=True;
  233.       End;
  234.       If JK and 1=0Then TextAttr($FF)
  235.                    Else TextAttr(7);
  236.       BarSpcHor(HomeX,HomeY+J,HomeX+9);
  237.      End;
  238.     End;
  239.     WaitRetrace;WaitRetrace;WaitRetrace;
  240.    End;
  241.    For J:=0to 19do Begin
  242.     Touch:=True;
  243.     For I:=0to 9do Touch:=Touch and Q.Tbl[J,I];
  244.     If(Touch)Then Begin
  245.      MoveRight(Q.Tbl[0,0],Q.Tbl[1,0],10*J);
  246.      FillChar(Q.Tbl[0,0],10,0);
  247.      MoveText(HomeX,HomeY,HomeX+9,HomeY+J-1,HomeX,HomeY+1);
  248.      Inc(Q.Score,LongInt(5)+(Bonus*4)*(Q.Level+1)+10*Q.Level); Inc(Q.Bar);
  249.      GotoXY(4,6);Write(Q.Score);
  250.      GotoXY(4,9);Write(Q.Bar);
  251.      I:=(Q.Bar+Q.FBar)shr 4;
  252.      If(Q.Level<>I)Then Begin
  253.       Q.Level:=I;
  254.       GotoXY(4,3);Write(Q.Level+1);
  255.       If Q.SleepDelay>6Then Dec(Q.SleepDelay,2);
  256.      End;
  257.     End;
  258.    End;
  259.    If Q.Y<=1Then Begin
  260.     UpDateData:=False;
  261.     Exit;
  262.    End;
  263.    Init;
  264.   End;
  265.  End;
  266.  
  267.  Function GameOver:Word;Begin
  268.   GotoXY(10,7);Write('Partie Terminer');
  269.   If(Q.UpDate)Then Begin
  270.    Q.UpDate:=False;
  271.   End;
  272.   GameOver:=kbEsc;
  273.  End;
  274.  
  275. Begin
  276.  TextMode(CO40);
  277.  TetrisRefresh(Q);
  278.  K:=0;
  279.  Repeat
  280.   Case(Q.Mode)of
  281.    tmStart:Begin
  282.     TetrisStart(Q);
  283.     TetrisRefresh(Q);
  284.     Init;
  285.     Q.Mode:=tmPlay;Q.UpDate:=True;
  286.    End;
  287.    tmPlay:Repeat
  288.     Begin
  289.      Repeat
  290.       If(Q.Sleep>Q.SleepDelay)Then If Not(UpDateData)Then Begin
  291.        Q.Mode:=tmGameOver;
  292.        Goto _Exit;
  293.       End;
  294.       WaitRetrace;
  295.       Inc(Q.Sleep);
  296.      Until KeyPressed;
  297.      K:=Byte(ReadKey);
  298.      If K=0Then K:=K or (Byte(ReadKey)shl 8);
  299.     End;
  300.     If Chr(K)='2'Then K:=kbDn;
  301.     If Chr(K)='4'Then K:=kbLeft;
  302.     If Chr(K)='6'Then K:=kbRight;
  303.     NoAction:=False;
  304.     Case(K)of
  305.      kbLeft:If Q.X>0Then Begin
  306.       Touch:=False;
  307.       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];
  308.       If Not(Touch)Then Begin
  309.        PutForm(True);
  310.        Dec(Q.X);
  311.        PutForm(False);
  312.       End;
  313.      End;
  314.      kbRight:If Q.X+BlkLength[Q.Form,Q.Move]-1<9Then Begin
  315.       Touch:=False;
  316.       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];
  317.       If Not(Touch)Then Begin
  318.        PutForm(True);
  319.        Inc(Q.X);
  320.        PutForm(False);
  321.       End;
  322.      End;
  323.      kbDn:While(True)do Begin
  324.       If Not(UpDateData)Then Begin
  325.        Q.Mode:=tmGameOver;
  326.        Goto _Exit;
  327.       End;
  328.       If(Ok)Then Break;
  329.      End;
  330.      Else NoAction:=True;
  331.     End;
  332.     If(NoAction)Then Begin
  333.      If(K=kbKeyPad5)or(Char(K)in[' ','5'])Then Begin
  334.       Touch:=False;
  335.       For I:=0to 3do Begin
  336.        XT:=Q.X+BlkFormat[Q.Form,(Q.Move+1)and 3,I].X; Touch:=Touch or(XT>9);
  337.        Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,(Q.Move+1)and 3,I].Y,XT];
  338.       End;
  339.       If Not(Touch)Then Begin
  340.        PutForm(True);
  341.        Q.Move:=(Q.Move+1)and 3;
  342.        PutForm(False)
  343.       End
  344.        Else
  345.       Begin
  346.        Touch:=False;
  347.        For I:=0to 3do Begin
  348.         XT:=Q.X;
  349.         If XT>0Then Dec(XT);
  350.         Inc(XT,BlkFormat[Q.Form,(Q.Move+1)and 3,I].X); Touch:=Touch or(XT>9);
  351.         Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,(Q.Move+1)and 3,I].Y,XT];
  352.        End;
  353.        If Not(Touch)Then Begin
  354.         PutForm(True);
  355.         Dec(Q.X); Q.Move:=(Q.Move+1)and 3;
  356.         PutForm(False);
  357.        End;
  358.       End;
  359.      End
  360.       Else
  361.      Break;
  362.     End;
  363.    Until(K=kbEsc)or(Chr(K)='Q');
  364.    tmGameOver:K:=GameOver;
  365.   End;
  366. _Exit:
  367.   If K<>0Then Break;
  368.  Until False;
  369.  TetrisPlay:=K;
  370. End;
  371.  
  372. Var
  373.  Game:TetrisGame;
  374.  
  375. BEGIN
  376.  TetrisInit(Game);
  377.  TetrisPlay(Game);
  378. END.

Dernière mise à jour : Vendredi, le 29 juillet 2016