home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 26 / CD_ASCQ_26_1295.iso / voxrom / textes / repwin08 / annexes / dionys / d_hanoi / hanoi.pas < prev   
Pascal/Delphi Source File  |  1995-10-01  |  16KB  |  497 lines
  1. Program JeuHanoi;
  2.  
  3. Uses Graph, Crt;
  4.  
  5. (**************** Declarations des TYPES ***********************************)
  6.  
  7. Type TDisque = Record
  8.          Diam : Word;      { un disque est représenté par son diamètre }
  9.          Coul : Byte;      { et par sa couleur }
  10.      End;
  11.  
  12. Type TPoint = Record      { Un point à l'écran }
  13.          X,Y : Word;
  14.      End;
  15.  
  16. Type TPtPile = ^TElemPile;  { Une pile est un pointeur sur un élément d'une pile }
  17.      TElemPile = Record   { Un élément d'une pile contient: }
  18.          Disque : TDisque;       { - Un disque }
  19.          Reste_Pile : TPtPile;   { - Le reste de la pile }
  20.      End;
  21.  
  22. { Description de l'objet Pile. Une pile est constituée de
  23.   - Une liste d'éléments (une liste de disques)
  24.   - Les actions associées. On ne peut réaliser que 3 actions sur une pile:
  25.         * Empiler un élément (un disque)
  26.         * Dépiler un élément
  27.         * Tester si la pile est vide }
  28. Type TPile = Object
  29.          Pile : TPtPile;
  30.  
  31.          Procedure Init;    { Vide la pile }
  32.          Procedure Empile(Disque : TDisque);
  33.          Procedure Depile(Var Disque : TDisque);
  34.          Function  EstVide : Boolean;
  35.      End;
  36.  
  37. { Description d'un Baton qui va contenir une série de disques, et des
  38.   2 actions possibles sur un tel baton:
  39.     - Enfiler un disque
  40.     - Défiler un disque }
  41. Type TBaton = Object
  42.          Pile : TPile;         { Pile de disques }
  43.          NbDisques : Byte;     { Nombre de disques emfilés sur le baton }
  44.          AuDessus  : TDisque;  { Disque qui se trouve au dessus du baton, prêt à
  45.                                  être enfilé. }
  46.          Position  : TPoint;   { Position du baton à l'écran. Le baton est repéré
  47.                                  par sa base }
  48.          Hauteur   : Word;     { Hauteur du baton (en points) }
  49.  
  50.          Procedure Init(X,Y,Haut : Word);    { Initialise le baton:
  51.                                                     - sa position et sa hauteur
  52.                                                     - vide la pile de disques }
  53.          Function  GetNbDisques : Byte;   { Renvoi le nombre de disques enfilés }
  54.          Procedure PoseDessus(Disque : TDisque); { Pose au dessus du baton, prêt à
  55.                                                  enfiler }
  56.          Procedure Enfile;      { Enfile le disque situé au dessus du baton }
  57.          Procedure Defile;      { Defile le premier disque qui se trouve ensuite
  58.                                   au dessus du baton }
  59.          Procedure Done;        { Vide proprement la pile de disques }
  60.      End;
  61.  
  62. { Le jeu en lui même, avec sa règle unique }
  63. Type THanoi = Object
  64.  
  65.          Baton1, Baton2, Baton3 : TBaton; { Le jeu est composé de 3 batons }
  66.  
  67.          { Initialise le jeu:
  68.              - Sa position (repéré par sa base sur laquelle sont posés les batons)
  69.              - La hauteur du jeu
  70.              - L'intervalle entre les batons
  71.              - Enfile tous les disques sur le premier baton}
  72.          Procedure Init(X,Y,Hauteur,Intervalle : Word);
  73.          { La seule régle du jeu: déplacer les disques d'un baton à l'autre
  74.            sachant que l'on ne peut pas poser un disque d'un diamètre donné
  75.            sur un disque de diamètre plus petit. }
  76.          Procedure Deplace(var BatonO, BatonD : TBaton);
  77.          Procedure Joue;
  78.          Procedure Solution(Var Tour1, Tour2, Tour3 : TBaton; NbDisq : Byte);
  79.          Procedure Done;
  80.      End;
  81.  
  82. (**************** Declarations des CONSTANTES ******************************)
  83.  
  84. Const HautDisque = 30;
  85.  
  86.       NoDisq : TDisque = (Diam : 0;   Coul : 0);
  87.       Disq1  : TDisque = (Diam : 170; Coul : 9);
  88.       Disq2  : TDisque = (Diam : 150; Coul : 10);
  89.       Disq3  : TDisque = (Diam : 130; Coul : 11);
  90.       Disq4  : TDisque = (Diam : 110; Coul : 12);
  91.       Disq5  : TDisque = (Diam : 90;  Coul : 13);
  92.       Disq6  : TDisque = (Diam : 70;  Coul : 14);
  93.       Disq7  : TDisque = (Diam : 50;  Coul : 15);
  94.  
  95. (***************** Code des OBJETS *****************************************)
  96.  
  97. (* --------------- Objet TPILE ------------ *)
  98.  
  99. Procedure TPile.Init;
  100. Begin
  101.      Pile := NIL
  102. End;
  103.  
  104. Procedure TPile.Empile;
  105. Var ElemPile : TPtPile;
  106. Begin
  107.      New (ElemPile);
  108.      ElemPile^.Disque     := Disque;
  109.      ElemPile^.Reste_Pile := Pile;
  110.      Pile                 := ElemPile
  111. End;
  112.  
  113. Procedure TPile.Depile;
  114. Var ElemPile : TPtPile;
  115. Begin
  116.      If Not EstVide
  117.      Then Begin
  118.           ElemPile := Pile;
  119.           Disque   := ElemPile^.Disque;
  120.           Pile     := ElemPile^.Reste_Pile;
  121.           Dispose (ElemPile)
  122.      End
  123.      Else Disque := NoDisq
  124. End;
  125.  
  126. Function  TPile.EstVide;
  127. Begin
  128.      EstVide := (Pile=NIL)
  129. End;
  130.  
  131. (* --------------- Objet TBATON ----------- *)
  132.  
  133. Procedure TBaton.Init;
  134. Begin
  135.      SetLineStyle (SolidLn,0,NormWidth);
  136.      SetColor (Yellow);
  137.      Rectangle (X-3,Y-Haut,X+3,Y);
  138.      Position.X := X;
  139.      Position.Y := Y;
  140.      Hauteur    := Haut;
  141.      NbDisques  := 0;
  142.      AuDessus   := NoDisq;
  143.      Pile.Init
  144. End;
  145.  
  146. Function  TBaton.GetNbDisques;
  147. Begin
  148.      GetNbDisques := NbDisques
  149. End;
  150.  
  151. Procedure TBaton.PoseDessus;
  152. Begin
  153.      AuDessus := Disque
  154. End;
  155.  
  156. Procedure TBaton.Enfile;
  157. Var Haut : TPoint;
  158.     Bas  : TPoint;
  159.     YCpt : Word;
  160. Begin
  161.      If AuDessus.Diam = 0
  162.         Then Exit;
  163.      Haut.X := Position.X - AuDessus.Diam div 2;
  164.      Haut.Y := Position.Y - Hauteur - HautDisque - 20;
  165.      Bas.X  := Position.X - AuDessus.Diam div 2;
  166.      Bas.Y  := Position.Y - (HautDisque+1) * (NbDisques+1);
  167.      With Haut Do
  168.      Begin
  169.           SetFillStyle (SolidFill,AuDessus.Coul);
  170.           Bar (X, Y, X + AuDessus.Diam, Y + HautDisque);
  171.           For YCpt := Y To Bas.Y-1 Do
  172.           Begin
  173.                SetColor (Black);
  174.                Line(X, YCpt, X + AuDessus.Diam, YCpt);
  175.                If YCpt = Position.Y-Hauteur
  176.                Then Begin
  177.                     SetColor (Yellow);
  178.                     Line (Position.X - 3, YCpt, Position.X + 3, YCpt)
  179.                End;
  180.                If YCpt > Position.Y-Hauteur
  181.                Then Begin
  182.                     PutPixel (Position.X - 3, YCpt,Yellow);
  183.                     PutPixel (Position.X + 3, YCpt,Yellow)
  184.                End;
  185.                SetColor (AuDessus.Coul);
  186.                Line (X, YCpt + HautDisque + 1, X + AuDessus.Diam,YCpt + HautDisque + 1)
  187.           End
  188.      End;
  189.      Pile.Empile (AuDessus);
  190.      Inc (NbDisques);
  191.      AuDessus := NoDisq
  192. End;
  193.  
  194. Procedure TBaton.Defile;
  195. Var Haut : TPoint;
  196.     Bas  : TPoint;
  197.     YCpt : Word;
  198.     Disque : TDisque;
  199. Begin
  200.      If NbDisques=0
  201.         Then Exit;
  202.      If Pile.EstVide
  203.         Then Exit;
  204.      Pile.Depile(Disque);
  205.      If Disque.Diam=0
  206.         Then Exit;
  207.      Haut.X := Position.X - Disque.Diam div 2;
  208.      Haut.Y := Position.Y - Hauteur - 20;
  209.      Bas.X  := Position.X - Disque.Diam div 2;
  210.      Bas.Y  := Position.Y - (HautDisque+1) * (NbDisques-1)-1;
  211.      With Bas Do
  212.      Begin
  213.           SetFillStyle (SolidFill,Disque.Coul);
  214.           Bar (X, Y - HautDisque, X + Disque.Diam, Y);
  215.           For YCpt := Y DownTo Haut.Y+1 Do
  216.           Begin
  217.                SetColor (Black);
  218.                Line(X, YCpt, X + Disque.Diam, YCpt);
  219.                If YCpt = Position.Y-Hauteur
  220.                Then Begin
  221.                     SetColor (Yellow);
  222.                     Line (Position.X - 3, YCpt, Position.X + 3, YCpt)
  223.                End;
  224.                If YCpt > Position.Y-Hauteur
  225.                Then Begin
  226.                     PutPixel (Position.X - 3, YCpt,Yellow);
  227.                     PutPixel (Position.X + 3, YCpt,Yellow)
  228.                End;
  229.                SetColor (Disque.Coul);
  230.                Line (X, YCpt - HautDisque - 1, X + Disque.Diam,YCpt - HautDisque - 1)
  231.           End
  232.      End;
  233.      Dec (NbDisques);
  234.      AuDessus := Disque
  235. End;
  236.  
  237. Procedure TBaton.Done;
  238. Var Disque : TDisque;
  239. Begin
  240.      While Not Pile.EstVide Do
  241.            Pile.Depile(Disque)
  242. End;
  243.  
  244. (* --------------- Objet THANOI ----------- *)
  245.  
  246. Procedure InitGraphique; External;
  247.  
  248. Procedure THanoi.Init;
  249. Var Place : Word;
  250. Begin
  251.      InitGraphique;
  252.      SetLineStyle(SolidLn,0,NormWidth);
  253.      SetColor(Yellow);
  254.      Rectangle(X,Y,X + 3*intervalle, Y+10);
  255.      Place := X + Intervalle div 2;
  256.      Baton1.Init(Place, Y, Hauteur);
  257.      Place := Place + Intervalle;
  258.      Baton2.Init(Place, Y, Hauteur);
  259.      Place := Place + Intervalle;
  260.      Baton3.Init (Place, Y, Hauteur);
  261.      With Baton1 Do
  262.      Begin
  263.           PoseDessus(Disq1);
  264.           Enfile;
  265.           PoseDessus(Disq2);
  266.           Enfile;
  267.           PoseDessus(Disq3);
  268.           Enfile;
  269.           PoseDessus(Disq4);
  270.           Enfile;
  271.           PoseDessus(Disq5);
  272.           Enfile;
  273.           PoseDessus(Disq6);
  274.           Enfile;
  275.           PoseDessus(Disq7);
  276.           Enfile
  277.      End
  278. End;
  279.  
  280. Procedure THanoi.Deplace;
  281. Var Depart,Fin : TPoint;
  282.  
  283.     Procedure DeplaceGD;
  284.     Var XCpt : Word;
  285.     Begin
  286.          For XCpt := Depart.X To Fin.X-1 Do
  287.          Begin
  288.                SetColor (BatonO.AuDessus.Coul);
  289.                Line (XCpt + BatonO.AuDessus.Diam + 1, Depart.Y,
  290.                      XCpt + BatonO.AuDessus.Diam + 1, Depart.Y + HautDisque);
  291.                SetColor (Black);
  292.                Line (XCpt, Depart.Y, XCpt, Depart.Y + HautDisque)
  293.          End
  294.     End;
  295.  
  296.     Procedure DeplaceDG;
  297.     Var XCpt : Word;
  298.     Begin
  299.          For XCpt := Depart.X DownTo Fin.X+1 Do
  300.          Begin
  301.                SetColor (BatonO.AuDessus.Coul);
  302.                Line (XCpt - 1, Depart.Y, XCpt - 1, Depart.Y + HautDisque);
  303.                SetColor (Black);
  304.                Line (XCpt + BatonO.AuDessus.Diam, Depart.Y,
  305.                      XCpt + BatonO.AuDessus.Diam, Depart.Y + HautDisque)
  306.          End
  307.     End;
  308.  
  309. Begin
  310.      If BatonO.Position.X = BatonD.Position.X
  311.         Then Exit;
  312.      BatonO.Defile;
  313.      With Depart Do
  314.      Begin
  315.           X := BatonO.Position.X - BatonO.AuDessus.Diam div 2;
  316.           Y := BatonO.Position.Y - BatonO.Hauteur - HautDisque - 20
  317.      End;
  318.      With Fin Do
  319.      Begin
  320.           X := BatonD.Position.X - BatonO.AuDessus.Diam div 2;
  321.           Y := Depart.Y
  322.      End;
  323.      If (BatonO.Position.X < BatonD.Position.X)
  324.         Then DeplaceGD
  325.         Else DeplaceDG;
  326.      BatonD.PoseDessus (BatonO.AuDessus);
  327.      BatonO.AuDessus.Diam := 0;
  328.      BatonO.AuDessus.Coul := 0;
  329.      BatonD.Enfile
  330. End;
  331.  
  332. Procedure THanoi.Joue;
  333. Var Disque1, Disque2 : TDisque;
  334.     Ch        : Char;
  335.     Continue  : Boolean;
  336.     Orig, Fin : Byte;
  337.  
  338.     Procedure Bip;
  339.     Begin
  340.          Sound (250);
  341.          Delay (100);
  342.          NoSound
  343.     End;
  344.  
  345. Begin
  346.      Repeat
  347.            SetFillStyle (SolidFill,0);
  348.            Bar (Baton1.Position.X - 1, Baton1.Position.Y + 11,
  349.                 Baton3.Position.X, Baton3.Position.Y + 55);
  350.            SetTextJustify (LeftText, TopText);
  351.            SetTextStyle (SansSerifFont,HorizDir,2);
  352.            SetColor (White);
  353.            OutTextXY (Baton1.Position.X, Baton1.Position.Y + 30, 'De: ');
  354.            Repeat
  355.                  Repeat
  356.                        Repeat Until KeyPressed;
  357.                        Ch := ReadKey
  358.                  Until ( (Ord(Ch) > 48) And (Ord(Ch) < 52) ) Or (Ord(Ch) in [13,27]);
  359.                  If Ch in [#13,#27]
  360.                     Then Exit;
  361.                  Orig := Ord(Ch) - 48;
  362.                  Case Orig Of
  363.                       1 : Begin
  364.                                Continue := (Baton1.GetNbDisques > 0);
  365.                                Baton1.Pile.Depile (Disque1);
  366.                                Baton1.Pile.Empile (Disque1)
  367.                           End;
  368.                       2 : Begin
  369.                                Continue := (Baton2.GetNbDisques > 0);
  370.                                Baton2.Pile.Depile (Disque1);
  371.                                Baton2.Pile.Empile (Disque1)
  372.                           End;
  373.                       3 : Begin
  374.                                Continue := (Baton3.GetNbDisques > 0);
  375.                                Baton3.Pile.Depile (Disque1);
  376.                                Baton3.Pile.Empile (Disque1)
  377.                           End
  378.                  End;
  379.                  If Not Continue
  380.                     Then Bip
  381.            Until Continue;
  382.            SetColor (Red);
  383.            OutTextXY (Baton1.Position.X, Baton1.Position.Y + 30,'De: ');
  384.            OutTextXY (Baton1.Position.X + 35, Baton1.Position.Y + 30,Ch);
  385.  
  386.            SetColor (15);
  387.            OutTextXY (Baton2.Position.X, Baton2.Position.Y + 30, 'Vers: ');
  388.            Repeat
  389.                  Repeat
  390.                        Repeat Until KeyPressed;
  391.                        Ch := ReadKey
  392.                  Until ( (Ord(Ch) > 48) And (Ord(Ch) < 52) ) Or (Ord(Ch) in [13,27]);
  393.                  If Ch in [#13,#27]
  394.                     Then Exit;
  395.                  Fin := Ord(Ch) - 48;
  396.                  Case Fin Of
  397.                       1 : Begin
  398.                                If Baton1.GetNbDisques > 0
  399.                                Then Begin
  400.                                     Baton1.Pile.Depile (Disque2);
  401.                                     Baton1.Pile.Empile (Disque2);
  402.                                     Continue := (Disque2.Diam >= Disque1.Diam)
  403.                                End
  404.                                Else Continue := True
  405.                           End;
  406.                       2 : Begin
  407.                                If Baton2.GetNbDisques > 0
  408.                                Then Begin
  409.                                     Baton2.Pile.Depile (Disque2);
  410.                                     Baton2.Pile.Empile (Disque2);
  411.                                     Continue := (Disque2.Diam >= Disque1.Diam)
  412.                                End
  413.                                Else Continue := True
  414.                           End;
  415.                       3 : Begin
  416.                                If Baton3.GetNbDisques > 0
  417.                                Then Begin
  418.                                     Baton3.Pile.Depile (Disque2);
  419.                                     Baton3.Pile.Empile (Disque2);
  420.                                     Continue := (Disque2.Diam >= Disque1.Diam)
  421.                                End
  422.                                Else Continue := True
  423.                           End
  424.                  End;
  425.                  If Not Continue
  426.                     Then Bip
  427.            Until Continue;
  428.            SetColor (Red);
  429.            OutTextXY (Baton2.Position.X, Baton2.Position.Y + 30, 'Vers: ');
  430.            OutTextXY (Baton2.Position.X + 60, Baton2.Position.Y + 30, Ch);
  431.            Case Orig of
  432.                 1 : Case Fin Of
  433.                          2 : Deplace (Baton1, Baton2);
  434.                          3 : Deplace (Baton1, Baton3)
  435.                     End;
  436.                 2 : Case Fin Of
  437.                          1 : Deplace (Baton2, Baton1);
  438.                          3 : Deplace (Baton2, Baton3)
  439.                     End;
  440.                 3 : Case Fin Of
  441.                          1 : Deplace (Baton3, Baton1);
  442.                          2 : Deplace (Baton3, Baton2)
  443.                     End
  444.            End
  445.      Until Not Continue
  446. End;
  447.  
  448. Procedure THanoi.Solution;
  449. Begin
  450.      if keypressed then exit;
  451.      If NbDisq>0
  452.      Then Begin
  453.           Solution(Tour1, Tour3, Tour2, NbDisq-1);
  454.           Deplace(Tour1, Tour3);
  455.           Solution(Tour2, Tour1, Tour3, NbDisq - 1);
  456.      End;
  457. End;
  458.  
  459. Procedure THanoi.Done;
  460. Begin
  461.      CloseGraph;
  462.      Baton1.Done;
  463.      Baton2.Done;
  464.      Baton3.Done
  465. End;
  466.  
  467. (********************** Autre Code *****************************************)
  468.  
  469. Procedure InitGraphique;
  470. Var Driver  : Integer;
  471.     Mode    : Integer;
  472.     ErrCode : Integer;
  473.     RepBGI  : string;
  474. Begin
  475.   Driver := Detect;
  476.   RepBGI := ParamStr(0);
  477.   while RepBgi[ord(RepBgi[0])] <> '\' do dec(RepBgi[0]);
  478.   InitGraph(Driver, Mode,RepBGI);
  479.   ErrCode := GraphResult;
  480.   If ErrCode <> grOk
  481.   Then Begin
  482.     Writeln('Erreur graphique: ', GraphErrorMsg(ErrCode));
  483.     Halt(1)
  484.   End
  485. End;
  486.  
  487. Var Hanoi : THanoi;
  488.  
  489. Begin
  490.      Hanoi.Init(20,400,300,200);
  491.      if paramcount = 0
  492.        then Hanoi.Joue
  493.        else Hanoi.Solution (Hanoi.Baton1, Hanoi.Baton2, Hanoi.Baton3, 7);
  494.      Readkey;
  495.      Hanoi.Done
  496. End.
  497.