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 Free Pascal et son unité «Crt».

A l'aide du code source Pascal suivant pour le Free 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:=#254 ;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.  CursorOff;
  278.  TetrisRefresh(Q);
  279.  K:=0;
  280.  Repeat
  281.   Case(Q.Mode)of
  282.    tmStart:Begin
  283.     TetrisStart(Q);
  284.     TetrisRefresh(Q);
  285.     Init;
  286.     Q.Mode:=tmPlay;Q.UpDate:=True;
  287.    End;
  288.    tmPlay:Repeat
  289.     Begin
  290.      Repeat
  291.       If(Q.Sleep>Q.SleepDelay)Then If Not(UpDateData)Then Begin
  292.        Q.Mode:=tmGameOver;
  293.        Goto _Exit;
  294.       End;
  295.       WaitRetrace;
  296.       Inc(Q.Sleep);
  297.      Until KeyPressed;
  298.      K:=Byte(ReadKey);
  299.      If K=0Then K:=K or (Byte(ReadKey)shl 8);
  300.     End;
  301.     If Chr(K)='2'Then K:=kbDn;
  302.     If Chr(K)='4'Then K:=kbLeft;
  303.     If Chr(K)='6'Then K:=kbRight;
  304.     NoAction:=False;
  305.     Case(K)of
  306.      kbLeft:If Q.X>0Then Begin
  307.       Touch:=False;
  308.       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];
  309.       If Not(Touch)Then Begin
  310.        PutForm(True);
  311.        Dec(Q.X);
  312.        PutForm(False);
  313.       End;
  314.      End;
  315.      kbRight:If Q.X+BlkLength[Q.Form,Q._Move]-1<9Then Begin
  316.       Touch:=False;
  317.       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];
  318.       If Not(Touch)Then Begin
  319.        PutForm(True);
  320.        Inc(Q.X);
  321.        PutForm(False);
  322.       End;
  323.      End;
  324.      kbDn:While(True)do Begin
  325.       If Not(UpDateData)Then Begin
  326.        Q.Mode:=tmGameOver;
  327.        Goto _Exit;
  328.       End;
  329.       If(Ok)Then Break;
  330.      End;
  331.      Else NoAction:=True;
  332.     End;
  333.     If(NoAction)Then Begin
  334.      If(K=kbKeyPad5)or(Char(K)in[' ','5'])Then Begin
  335.       Touch:=False;
  336.       For I:=0to 3do Begin
  337.        XT:=Q.X+BlkFormat[Q.Form,(Q._Move+1)and 3,I].X; Touch:=Touch or(XT>9);
  338.        Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,(Q._Move+1)and 3,I].Y,XT];
  339.       End;
  340.       If Not(Touch)Then Begin
  341.        PutForm(True);
  342.        Q._Move:=(Q._Move+1)and 3;
  343.        PutForm(False)
  344.       End
  345.        Else
  346.       Begin
  347.        Touch:=False;
  348.        For I:=0to 3do Begin
  349.         XT:=Q.X;
  350.         If XT>0Then Dec(XT);
  351.         Inc(XT,BlkFormat[Q.Form,(Q._Move+1)and 3,I].X); Touch:=Touch or(XT>9);
  352.         Touch:=Touch or Q.Tbl[Q.Y+BlkFormat[Q.Form,(Q._Move+1)and 3,I].Y,XT];
  353.        End;
  354.        If Not(Touch)Then Begin
  355.         PutForm(True);
  356.         Dec(Q.X); Q._Move:=(Q._Move+1)and 3;
  357.         PutForm(False);
  358.        End;
  359.       End;
  360.      End
  361.       Else
  362.      Break;
  363.     End;
  364.    Until(K=kbEsc)or(Chr(K)='Q');
  365.    tmGameOver:K:=GameOver;
  366.   End;
  367. _Exit:
  368.   If K<>0Then Break;
  369.  Until False;
  370.  TetrisPlay:=K;
  371. End;
  372.  
  373. Var
  374.  Game:TetrisGame;
  375.  
  376. BEGIN
  377.  TetrisInit(Game);
  378.  TetrisPlay(Game);
  379. END.

Dernière mise à jour : Jeudi, le 29 décembre 2011