examples/geometri/p3d.log

   1 PROGRAM P3D;\r
   2   signal WIN1, WIN2, WIN3, PLEIN;\r
   3  \r
   4   UNIT INCHAR : IIuwgraph function : integer;\r
   5   begin\r
   6     do\r
   7       i := inkey;\r
   8       if i <> 0 then exit fi;\r
   9     od;\r
  10     result := i;\r
  11   end inchar;\r
  12  \r
  13   UNIT INIT_GRAPH : procedure;\r
  14   begin\r
  15   pref iiuwgraph block\r
  16   begin\r
  17     call hpage(0,1,1);\r
  18   end\r
  19   end init_graph;\r
  20 \r
  21 (* DEFINIT LES 27 ZONES ACTIVE DE L'ECRAN\r
  22    OU L'ON PEUT CLIQUER A LA SOURIS *)\r
  23 \r
  24   UNIT MOUSEPOS : function : integer;\r
  25     var x, y : integer,\r
  26     pressed, l, r, c : boolean;\r
  27   begin\r
  28   pref mouse block\r
  29   begin\r
  30     call showcursor;\r
  31     do\r
  32       call getpress(0,x,y,b,l,r,c);\r
  33       if l then\r
  34       if ((x>110) and (x<130))\r
  35         then if ((y>290) and (y<310)) then result := 1; exit fi;\r
  36              if ((y>190) and (y<210)) then result := 11; exit fi;\r
  37              if ((y>090) and (y<110)) then result := 21; exit fi;\r
  38       fi;\r
  39       if ((x>260) and (x<280))\r
  40         then if ((y>290) and (y<310)) then result := 2; exit fi;\r
  41              if ((y>190) and (y<210)) then result := 12; exit fi;\r
  42              if ((y>090) and (y<110)) then result := 22; exit fi;\r
  43       fi;\r
  44       if ((x>410) and (x<430))\r
  45         then if ((y>290) and (y<310)) then result := 3; exit fi;\r
  46              if ((y>190) and (y<210)) then result := 13; exit fi;\r
  47              if ((y>090) and (y<110)) then result := 23; exit fi;\r
  48       fi;\r
  49       if ((x>160) and (x<180))\r
  50         then if ((y>250) and (y<270)) then result := 4; exit fi;\r
  51              if ((y>150) and (y<170)) then result := 14; exit fi;\r
  52              if ((y>050) and (y<070)) then result := 24; exit fi;\r
  53       fi;\r
  54       if ((x>310) and (x<330))\r
  55         then if ((y>250) and (y<270)) then result := 5; exit fi;\r
  56              if ((y>150) and (y<170)) then result := 15; exit fi;\r
  57              if ((y>050) and (y<070)) then result := 25; exit fi;\r
  58       fi;\r
  59       if ((x>460) and (x<480))\r
  60         then if ((y>250) and (y<270)) then result := 6; exit fi;\r
  61              if ((y>150) and (y<170)) then result := 16; exit fi;\r
  62              if ((y>050) and (y<070)) then result := 26; exit fi;\r
  63       fi;\r
  64       if ((x>210) and (x<230))\r
  65         then if ((y>210) and (y<230)) then result := 7; exit fi;\r
  66              if ((y>110) and (y<130)) then result := 17; exit fi;\r
  67              if ((y>010) and (y<030)) then result := 27; exit fi;\r
  68       fi;\r
  69       if ((x>360) and (x<380))\r
  70         then if ((y>210) and (y<230)) then result := 8; exit fi;\r
  71              if ((y>110) and (y<130)) then result := 18; exit fi;\r
  72              if ((y>010) and (y<030)) then result := 28; exit fi;\r
  73       fi;\r
  74       if ((x>510) and (x<530))\r
  75         then if ((y>210) and (y<230)) then result := 9; exit fi;\r
  76              if ((y>110) and (y<130)) then result := 19; exit fi;\r
  77              if ((y>010) and (y<030)) then result := 29; exit fi;\r
  78       fi;\r
  79     fi\r
  80     od;\r
  81     call hidecursor;\r
  82     end\r
  83   end mousepos;\r
  84 \r
  85 (* STRUCTURE DEFINISSANT 3 CASES (BOX) ALIGNEES DANS LE CUBE *)\r
  86 \r
  87     UNIT LIGNE : class(tab_nb : arrayof integer);\r
  88       var suiv, pred  : ligne,\r
  89           occur       : arrayof box,\r
  90           i           : integer;\r
  91  \r
  92       UNIT box : class(nb : integer);\r
  93         var no   : integer,\r
  94             flag : boolean;\r
  95       begin\r
  96         no := nb;\r
  97         flag := false\r
  98       end box;\r
  99  \r
 100     begin\r
 101       array occur dim(1:3);\r
 102       for i := 1 to 3 do occur(i) := new box(tab_nb(i)) od\r
 103     end ligne;\r
 104  \r
 105 (* LISTE DOUBLEMENT CHAINEE : POSSIBILITES D'UN JOUEUR *)\r
 106 \r
 107   UNIT POSS : class;\r
 108     var tactik,fin : ligne;\r
 109  \r
 110     UNIT VIDE : function : boolean;\r
 111     begin\r
 112       result := tactik = NONE\r
 113     end vide;\r
 114  \r
 115     UNIT DELPOSS : procedure;\r
 116     begin\r
 117       do\r
 118          if vide then exit fi;\r
 119          call supprimer(tactik);\r
 120       od\r
 121     end delposs;\r
 122  \r
 123     UNIT SUPPRIMER : procedure(e : ligne);\r
 124       var aux : ligne;\r
 125     begin\r
 126       if e=tactik\r
 127         then\r
 128           tactik:=tactik.suiv;\r
 129           kill(e);\r
 130           exit\r
 131         else\r
 132           if e=fin\r
 133             then\r
 134               fin := fin.pred;\r
 135               kill(e);\r
 136               exit\r
 137             else\r
 138           fi\r
 139       fi;\r
 140       aux := tactik.suiv;\r
 141       do\r
 142         if aux=e\r
 143           then\r
 144             aux.pred.suiv := aux.suiv;\r
 145             aux.suiv.pred := aux.pred;\r
 146             kill(aux);\r
 147             exit\r
 148           else\r
 149             aux := aux.suiv\r
 150         fi\r
 151       od\r
 152     end supprimer;\r
 153  \r
 154     UNIT AJOUTER : procedure(e : ligne);\r
 155       var i : integer;\r
 156     begin\r
 157       if vide then tactik,fin := e\r
 158               else fin.suiv := e;\r
 159                    e.pred := fin;\r
 160                    fin := e\r
 161       fi\r
 162     end ajouter;\r
 163   end poss;\r
 164  \r
 165   UNIT ELEMENT : class;\r
 166     var tab : arrayof integer,\r
 167         suivant : element;\r
 168   begin\r
 169     array tab dim(1:3)\r
 170   end element;\r
 171 \r
 172 (* PILE D'ELEMENTS : LISTE DE TOUTES LES SOLUTIONS POUR UNE CASE DONNEE *)\r
 173 \r
 174   UNIT PILE : class;\r
 175     var tete : element;\r
 176  \r
 177     UNIT PILEVIDE : function : boolean;\r
 178     begin\r
 179       result := tete = NONE\r
 180     end pilevide;\r
 181  \r
 182     UNIT EMPILER : procedure(e : element);\r
 183     begin\r
 184       if not pilevide then e.suivant := tete fi;\r
 185       tete := e\r
 186     end empiler;\r
 187  \r
 188     UNIT DEPILER : function : element;\r
 189       var aux : element;\r
 190     begin\r
 191       result := tete;\r
 192       if not pilevide then tete := tete.suivant fi\r
 193     end depiler;\r
 194  \r
 195     UNIT DELPILE : procedure;\r
 196       var aux : element;\r
 197     begin\r
 198       do if pilevide then exit fi;\r
 199         aux := tete;\r
 200         tete := tete.suivant;\r
 201         kill(aux)\r
 202       od\r
 203     end delpile;\r
 204   end pile;\r
 205 \r
 206 (* LISTE DE NUMEROS DE CASE A NE PAS JOUER *)\r
 207 \r
 208   UNIT LISTE : class;\r
 209     var tete, queue : numero;\r
 210  \r
 211     UNIT NUMERO : class(val : integer);\r
 212       var next : numero;\r
 213     end numero;\r
 214  \r
 215     UNIT LISTEVIDE : function : boolean;\r
 216     begin\r
 217       if tete = NONE then result := true fi\r
 218     end listevide;\r
 219  \r
 220     UNIT AJOUT : procedure(e : integer);\r
 221       var aux : numero;\r
 222     begin\r
 223       if listevide then tete, queue := new numero(e)\r
 224                    else aux := new numero(e);\r
 225                         queue.next := aux;\r
 226                         queue := aux\r
 227       fi\r
 228     end ajout;\r
 229  \r
 230     UNIT MEMBER : function(e : integer) : boolean;\r
 231       var aux : numero;\r
 232     begin\r
 233       if listevide then exit fi;\r
 234       aux := tete;\r
 235       do if aux = NONE then exit fi;\r
 236          if aux.val = e then result := true;\r
 237                              exit\r
 238                         else aux := aux.next\r
 239          fi\r
 240       od\r
 241     end member;\r
 242  \r
 243     UNIT DELLISTE : procedure;\r
 244       var aux : numero;\r
 245     begin\r
 246       do if listevide then exit fi;\r
 247          aux := tete.next;\r
 248          kill(tete);\r
 249          tete := aux\r
 250       od\r
 251     end delliste;\r
 252   end liste;\r
 253 \r
 254 (* INITIALISATION DU CUBE MATERIALISE PAR UN TABLEAU A TROIS DIMENSIONS *)\r
 255 \r
 256   UNIT M3D : class;\r
 257     var i, j, k : integer,\r
 258         chape   : arrayof arrayof arrayof integer;\r
 259  \r
 260   begin\r
 261     array chape dim (1:3);\r
 262     for i := 1 to 3\r
 263       do\r
 264         array chape(i) dim (1:3)\r
 265       od;\r
 266     for j := 1 to 3\r
 267       do\r
 268         for k := 1 to 3\r
 269           do\r
 270             array chape(j,k) dim (1:3)\r
 271           od\r
 272       od\r
 273   end M3D;\r
 274  \r
 275 (* TRANSFORME UN ENTIER X (0 < X < 28) EN COORDONNEES DU CUBE I,J,K *)\r
 276   UNIT INT_COORD : procedure (val : integer; output i, j, k : integer);\r
 277   begin\r
 278     k := (val div 10)+1;\r
 279     i := (((val mod 10)-1) div 3)+1;\r
 280     j := (((val mod 10)-1) mod 3)+1;\r
 281   end int_coord;\r
 282 \r
 283 (* MISE A JOUR DU TABLEAU DES COUPS OPTIMUMS *)\r
 284 \r
 285   UNIT MAJTOP : procedure(topcoup : arrayof integer);\r
 286     var i     : integer,\r
 287         lig   : ligne;\r
 288   begin\r
 289     for i := 1 to 29 do topcoup(i) := 0 od;\r
 290     lig := jeu1.tactik;\r
 291     do\r
 292       if lig = NONE then exit fi;\r
 293       for i := 1 to 3\r
 294         do\r
 295           if (not(lig.occur(i).flag) and (MDJ.disponible(lig.occur(i).no)))\r
 296             then topcoup(lig.occur(i).no) := topcoup(lig.occur(i).no) + 1\r
 297           fi\r
 298         od;\r
 299         lig := lig.suiv\r
 300     od\r
 301   end MAJTOP;\r
 302 \r
 303 (* MISE A JOUR DES LISTES DOUBLEMENT CHAINEES EN FONCTION DU COUPS JOUE *)\r
 304 \r
 305   UNIT MAJJEU : procedure (poss1 : poss);\r
 306     var poss2     : poss,\r
 307         sol       : element,\r
 308         lig, nouv : ligne,\r
 309         i, pasbon : integer,\r
 310         identique, good : boolean;\r
 311   begin\r
 312     if MDJ.premier then pasbon := 2;\r
 313                         poss2 := jeu2;\r
 314                    else pasbon := 1;\r
 315                         poss2 := jeu1\r
 316     fi;\r
 317     do\r
 318       if pile_sol.pilevide then exit fi;\r
 319       sol := pile_sol.depiler;\r
 320       lig := poss1.tactik;\r
 321       do\r
 322         if lig = NONE then exit fi;\r
 323         identique := true;\r
 324         for i := 1 to 3\r
 325           do if lig.occur(i).no = clic then lig.occur(i).flag := true fi;\r
 326              if lig.occur(i).no <> sol.tab(i)\r
 327                then identique := false\r
 328              fi\r
 329           od;\r
 330         if identique then exit fi;\r
 331         lig := lig.suiv;\r
 332       od;\r
 333       if not identique\r
 334         then\r
 335              good := true;\r
 336              for i := 1 to 3\r
 337                do\r
 338                  if MDJ.joue(sol.tab(i)) = pasbon\r
 339                    then\r
 340                      good := false;\r
 341                      exit\r
 342                  fi\r
 343                od;\r
 344              if good then\r
 345                nouv := new ligne(sol.tab);\r
 346                call poss1.ajouter(nouv);\r
 347                for i := 1 to 3\r
 348                  do if ((MDJ.joue(poss1.fin.occur(i).no) <> 0) or\r
 349                         (poss1.fin.occur(i).no = clic))\r
 350                       then poss1.fin.occur(i).flag := true\r
 351                     fi\r
 352                  od\r
 353              fi\r
 354       fi\r
 355     od;\r
 356     lig := poss2.tactik;\r
 357     do\r
 358       if lig = NONE then exit fi;\r
 359       for i := 1 to 3\r
 360         do if lig.occur(i).no = clic\r
 361              then\r
 362                nouv := lig.suiv;\r
 363                call poss2.supprimer(lig);\r
 364                exit\r
 365              else nouv := lig.suiv\r
 366            fi\r
 367         od;\r
 368       lig := nouv;\r
 369     od;\r
 370   end majjeu;\r
 371 \r
 372   UNIT ERREURCLIC : procedure;\r
 373   begin\r
 374     pref iiuwgraph block\r
 375     begin\r
 376       call hpage(1,1,1);\r
 377       call move(125,90);\r
 378       call color(12);\r
 379       call outstring("Cher utilisateur,");\r
 380       call move (100,100);\r
 381       call outstring("Vous ne pouvez jouer que sur des cases marrons !");\r
 382       call move(400,340);\r
 383       call color(14);\r
 384       call outstring("< Appuyez sur une touche >");\r
 385       i := 0;\r
 386       pref mouse block\r
 387       begin\r
 388       do\r
 389         if driver then\r
 390           call getpress(0,xm,ym,b,l,r,c);\r
 391           if l then l := false;\r
 392                     call setposition(xm+20,ym+20);\r
 393                     exit fi;\r
 394         fi;\r
 395         i:=inkey;\r
 396         if i<>0 then exit fi\r
 397       od\r
 398       end;\r
 399       call hpage(0,1,0);\r
 400     end\r
 401   end erreurclic;\r
 402 \r
 403 (* LE MAITRE DU JEU *)\r
 404 \r
 405   UNIT ARBITRE : class;\r
 406 \r
 407 (* DESSINE LE CUBE EN MODE GRAPHIQUE *)\r
 408     UNIT INIT_AFFCUBE : procedure;\r
 409       var i, j , k, x, y, couleur : integer;\r
 410   begin\r
 411   pref iiuwgraph block\r
 412     begin\r
 413       x := 120; y := 300;\r
 414       call color(9);\r
 415       call move(x,y);\r
 416       call draw(x,y-200); call draw(x+300,y-200);\r
 417       call draw(x+300,y); call draw(x,y);\r
 418       y := y-200; call move(x,y);\r
 419       call draw(x+100,y-75); call draw(x+400,y-75); call draw(x+300,y);\r
 420       call move(x+400,y-75);\r
 421       call draw(x+400,y+125); call draw(x+300,y+200);\r
 422       y := y+200; call move(x+350,y-37);\r
 423       call draw(x+350,y-237); call draw(x+50,y-237);\r
 424       call move(x+150,y);\r
 425       call draw(x+150,y-200); call draw(x+250,y-275);\r
 426       call move(x,y-100);\r
 427       call draw(x+300,y-100); call draw(x+400,y-175);\r
 428       call style(5); call move(x,y);\r
 429       call draw(x+100,y-75); call draw(x+100,y-275);\r
 430       call move(x+100,y-75); call draw(x+400,y-75);\r
 431       call move(x+350,y-37);\r
 432       call draw(x+50,y-37); call draw(x+50,y-237);\r
 433       call move(x+150,y);\r
 434       call draw(x+250,y-75); call draw(x+250,y-275);\r
 435       call move(x,y-100);\r
 436       call draw(x+100,y-175); call draw(x+400,y-175);\r
 437       call move(x+200,y-37); call draw(x+200,y-237);\r
 438       call move(x+50,y-137); call draw(x+350,y-137);\r
 439       call move(x+150,y-100); call draw(x+250,y-175);\r
 440       call style(1);\r
 441       call color(6);\r
 442       couleur := 6;\r
 443       for k := 1 to 3\r
 444         do if k > 1 then call color(15); couleur := 15 fi;\r
 445            for j := 1 to 3\r
 446              do for i := 1 to 3\r
 447                   do x := 120+(j-1)*150+(i-1)*50;\r
 448                      y := 300-((k-1)*100+(i-1)*37);\r
 449                      call cirb(x, y, 3, 0.0, 0.0, couleur, couleur, 1, 1);\r
 450                   od\r
 451              od\r
 452         od\r
 453     end\r
 454   end init_affcube;\r
 455 \r
 456 (* AFFICHE SUR LE CUBE L'ENDROIT OU A ETE JOUE LE COUPS *)\r
 457     UNIT AFFCOUPS : procedure(i,j,k : integer);\r
 458       var x, y : integer;\r
 459     begin\r
 460       pref iiuwgraph block\r
 461         begin\r
 462           x := 120+(j-1)*150+(i-1)*50;\r
 463           y := 300-((k-1)*100+(i-1)*37);\r
 464           x := x-3; y := y-4;\r
 465           call move(x,y);\r
 466           if MDJ.premier then call color(12)\r
 467                          else call color(10)\r
 468           fi;\r
 469           call outstring("Û");\r
 470           call move(x-5,y-3);\r
 471           call draw(x+12,y-3); call draw(x+12,y+10);\r
 472           call draw(x-5,y+10); call draw(x-5,y-3);\r
 473           call color(15);\r
 474         end\r
 475     end affcoups;\r
 476  \r
 477 (* INITIALISATION DES 13 FACES CONTENUES DANS LE CUBE :\r
 478    ASSOCIATION DE 9 NUMEROS DE CASES POUR CHACUNE D'ELLES *)\r
 479 \r
 480     UNIT INIT_FACES : procedure;\r
 481       var i, j, k, t : integer;\r
 482     begin\r
 483       array face dim(1:13);\r
 484       for i:= 1 to 13\r
 485         do array face(i) dim(1:9)\r
 486         od;\r
 487       for i := 1 to 9\r
 488         do face (1,i) := i;\r
 489            face (2,i) := i+10;\r
 490            face (3,i) := i+20;\r
 491            face (12,i) := 3*i;\r
 492         od;\r
 493       for i := 1 to 3\r
 494         do for j := 1 to 3\r
 495              do face (3+i, j) := i+3*(j-1);\r
 496                 face (3+i,j+3) := i+10+3*(j-1);\r
 497                 face (3+i,j+6) := i+20+3*(j-1);\r
 498              od;\r
 499         od;\r
 500       k := 1;\r
 501       for t := 1 to 3\r
 502         do for i := 7 to 9\r
 503              do for j := 1 to 3\r
 504                 do face (i,j+3*(t-1)) := k;\r
 505                    k := k+1;\r
 506                 od;\r
 507              od;\r
 508            k := k+1;\r
 509         od;\r
 510       for i := 1 to 3\r
 511         do face (10,i) := i;\r
 512            face (10,i+3) := i+13;\r
 513            face (10,i+6) := i+26;\r
 514         od;\r
 515       for i := 1 to 3\r
 516         do face (11,i) := i+6;\r
 517            face (11,i+3) := i+13;\r
 518            face (11,i+6) := i+20;\r
 519         od;\r
 520       for i := 1 to 3\r
 521         do face (13,i) := 1+3*(i-1);\r
 522            face (13,i+3) := face (13,i)+11;\r
 523            face (13,i+6) := face (13,i)+22;\r
 524         od;\r
 525     end init_faces;\r
 526 \r
 527 (* CREATION DU MASQUE POUR TROUVER TOUTES LES SOLUTIONS SELON UNE CASE *)\r
 528     UNIT INIT_MASK : procedure;\r
 529       var i : integer;\r
 530     begin\r
 531       array mask dim(1:8);\r
 532       for i := 1 to 8\r
 533         do array mask(i) dim(1:3) od;\r
 534       for i := 1 to 3 do mask(1,i) := i od;\r
 535       for i := 1 to 3 do mask(2,i) := i+3 od;\r
 536       for i := 1 to 3 do mask(3,i) := i+6 od;\r
 537       for i := 1 to 3 do mask(4,i) := 1+3*(i-1) od;\r
 538       for i := 1 to 3 do mask(5,i) := 2+3*(i-1) od;\r
 539       for i := 1 to 3 do mask(6,i) := 3+3*(i-1) od;\r
 540       for i := 1 to 3 do mask(7,i) := 1+4*(i-1) od;\r
 541       for i := 1 to 3 do mask(8,i) := 2*i+1 od;\r
 542     end INIT_MASK;\r
 543 \r
 544 (* EMPILE TOUTES LES SOLUTIONS SELON UNE CASE CHOISIE *)\r
 545     UNIT SOLUTIONS : procedure(nobox : integer);\r
 546       var i, j, k, l, m,z : integer,\r
 547           e          : element;\r
 548     begin\r
 549       call pile_sol.delpile;\r
 550       for i := 1 to 13\r
 551         do for j := 1 to 9\r
 552              do if face(i,j) = nobox\r
 553                   then for k := 1 to 8\r
 554                          do for l := 1 to 3\r
 555                               do if mask(k,l) = j\r
 556                                    then\r
 557                                      e := new element;\r
 558                                      for m := 1 to 3\r
 559                                        do\r
 560                                        e.tab(m) := face(i,mask(k,m)) od;\r
 561                                        call pile_sol.empiler(e);\r
 562                                  fi\r
 563                               od\r
 564                          od\r
 565                 fi\r
 566              od\r
 567         od\r
 568     end solutions;\r
 569 \r
 570 (* INDIQUE SI LA CASE CHOISIE PAR UN JOUEUR EST ACCESSIBLE OU NON *)\r
 571     UNIT DISPONIBLE : function (choix : integer) : boolean;\r
 572       var i, j, k : integer;\r
 573     begin\r
 574       result := false;\r
 575       call int_coord(choix,i,j,k);\r
 576       if dispo(i,j) = choix then result := true fi\r
 577     end disponible;\r
 578 \r
 579 (* MISE A JOUR DE LA MATRICE CONTENANT TOUTES LES CASE DISPONIBLES.\r
 580    CHANGEMENT DE COULEUR POUR LE PION SITUE AU DESSUS DU COUPS JOUE *)\r
 581 \r
 582     UNIT MAJDISPO : procedure(i, j ,k : integer);\r
 583     var x, y, h, c, l : integer;\r
 584     begin\r
 585       dispo(i,j) := dispo(i,j)+10;\r
 586       pref iiuwgraph block\r
 587       begin\r
 588       if dispo(i,j) > 29\r
 589         then dispo(i,j) := 0\r
 590         else call int_coord(dispo(i,j), c, l, h);\r
 591           x := 120+(l-1)*150+(c-1)*50;\r
 592           y := 300-((h-1)*100+(c-1)*37);\r
 593           call color(6);\r
 594           call cirb(x, y, 3, 0.0, 0.0, 6, 6, 1, 1);\r
 595       fi\r
 596       end\r
 597     end majdispo;\r
 598 \r
 599 (* RENVOIE, POUR UNE CASE DONNEE, LE NUMERO DU JOUEUR QUI A JOUE DESSUS *)\r
 600     UNIT JOUE : function(endroit : integer) : integer;\r
 601       var i, j, k : integer;\r
 602     begin\r
 603       call int_coord(endroit, i, j, k);\r
 604       result := cube.chape(i,j,k)\r
 605     end joue;\r
 606 \r
 607 (* MISE A JOUR DES NUMEROS DU CUBE POUR SAVOIR QUI A JOUE A QUEL ENDROIT.\r
 608    POR SAVOIR SI LE CUBE EST PLEIN OU SI UN JOUEUR A GAGNE *)\r
 609 \r
 610     UNIT MAJCUBE : function(i, j, k : integer; nojoueur : boolean) : integer;\r
 611       var m, n    : integer,\r
 612           x, y, x1, y1, z1, x2, y2, z2 : integer,\r
 613           pasfini : boolean,\r
 614           poss1   : poss,\r
 615           aux     : ligne;\r
 616     begin\r
 617       result := 0;\r
 618       pasfini := false;\r
 619       if nojoueur then cube.chape(i, j, k) := 1;\r
 620                   else cube.chape(i, j, k) := 2\r
 621       fi;\r
 622       for m := 1 to 3\r
 623         do for n := 1 to 3\r
 624              do if cube.chape(m,n,3) = 0\r
 625                   then pasfini := true;\r
 626                        exit exit\r
 627                 fi\r
 628              od\r
 629         od;\r
 630       if not pasfini then result := FINI fi;\r
 631       if MDJ.premier then poss1 := jeu1\r
 632                      else poss1 := jeu2\r
 633       fi;\r
 634       aux := poss1.tactik;\r
 635       pasfini := false;\r
 636       while ((aux <> NONE) and (not pasfini))\r
 637         do if (aux.occur(1).flag AND\r
 638                aux.occur(2).flag AND\r
 639                aux.occur(3).flag)\r
 640              then pref iiuwgraph block\r
 641                   begin\r
 642                   call color(11);\r
 643                   call int_coord(aux.occur(1).no,x1,y1,z1);\r
 644                   call int_coord(aux.occur(3).no,x2,y2,z2);\r
 645                   x := 120+(y1-1)*150+(x1-1)*50;\r
 646                   y := 300-((z1-1)*100+(x1-1)*37);\r
 647                   call move(x,y);\r
 648                   x := 120+(y2-1)*150+(x2-1)*50;\r
 649                   y := 300-((z2-1)*100+(x2-1)*37);\r
 650                   call draw(x,y);\r
 651                   call color(15);\r
 652                   end;\r
 653                   pasfini := true;\r
 654              else aux := aux.suiv\r
 655            fi;\r
 656         od;\r
 657       if pasfini then\r
 658          result := GAGNE fi;\r
 659     end majcube;\r
 660 \r
 661 (* DECLARATIONS DES VARIABLES DE L'ARBITRE *)\r
 662     const GAGNE = 1, FINI = 2;\r
 663     var cube        : M3D,\r
 664         face, mask  : arrayof arrayof integer,\r
 665         premier     : boolean,\r
 666         x, y, z,\r
 667         i, j,\r
 668         resultat    : integer,\r
 669         joueur1     : strat1,\r
 670         joueur2     : strat2,\r
 671         joueur3     : user;\r
 672 \r
 673 \r
 674 (* LE MAITRE DE JEU ENGAGE LA PARTIE *)\r
 675 \r
 676     UNIT START_GAME : procedure;\r
 677     begin\r
 678     pref iiuwgraph block\r
 679     begin\r
 680       pile_sol := new pile;\r
 681       listdef  := new liste;\r
 682       call init_faces;\r
 683       call init_mask;\r
 684       cube := new M3D;\r
 685       call init_affcube;\r
 686       array dispo dim(1:3);\r
 687       for i := 1 to 3\r
 688         do array dispo(i) dim(1:3);\r
 689            for j := 1 to 3 do dispo(i,j) := i*3+j-3 od\r
 690         od;\r
 691       premier := true;\r
 692       do\r
 693         call move(100,320);\r
 694         call color(4);\r
 695         if nbjoueur\r
 696           then call outstring("Choisissez la premi\8are case du joueur ROUGE");\r
 697           else call outstring("Choisissez la premi\8are case pour l'ORDINATEUR")\r
 698         fi;\r
 699         joueur1 := new strat1;\r
 700         if disponible(clic) then exit fi;\r
 701           call erreurclic;\r
 702         kill(joueur1)\r
 703       od;\r
 704       call int_coord(clic, x, y, z);\r
 705       call solutions(clic);\r
 706       i := majcube(x,y,z,premier);\r
 707       call majdispo(x, y, z);\r
 708       call majjeu(jeu1);\r
 709       call affcoups(x,y,z);\r
 710       premier := not premier;\r
 711       do\r
 712         call move(100,320);\r
 713         if nbjoueur\r
 714         then\r
 715           call color(2);\r
 716           call outstring("Choisissez la premi\8are case du joueur VERT    ");\r
 717           joueur2 := new strat2;\r
 718           if disponible(clic) then exit fi;\r
 719           call erreurclic;\r
 720           kill(joueur2)\r
 721         else\r
 722           call outstring("                                              ");\r
 723           call move(100,320);\r
 724           call color(14);\r
 725           call outstring("Votre choix ? ");\r
 726           joueur3 := new user;\r
 727           if disponible(clic) then exit fi;\r
 728           call erreurclic;\r
 729           kill(joueur3)\r
 730         fi;\r
 731       od;\r
 732       call move(100,320);\r
 733       call outstring("                                              ");\r
 734       call int_coord(clic, x, y, z);\r
 735       call solutions(clic);\r
 736       i := majcube(x,y,z,premier);\r
 737       call majdispo(x, y, z);\r
 738       call majjeu(jeu2);\r
 739       call affcoups(x, y, z);\r
 740       premier := not premier;\r
 741       do\r
 742         do\r
 743           if premier then attach(joueur1)\r
 744                      else if nbjoueur then attach(joueur2)\r
 745                                       else attach(joueur3)\r
 746                           fi\r
 747           fi;\r
 748           if disponible(clic) then exit fi;\r
 749         od;\r
 750         call int_coord(clic, x, y, z);\r
 751         resultat := majcube(x, y, z, premier);\r
 752         call affcoups(x, y, z);\r
 753         if resultat = GAGNE\r
 754           then if premier then raise WIN1\r
 755                           else if nbjoueur then raise WIN2\r
 756                                            else raise WIN3\r
 757                                fi\r
 758                fi\r
 759         fi;\r
 760         if resultat = FINI then raise PLEIN fi;\r
 761         call majdispo(x, y, z);\r
 762         premier := not premier;\r
 763       od;\r
 764       lastwill : call move(70,340);\r
 765                  call color(3);\r
 766                  call outstring("Arbitre : Belle partie n'est-ce pas ?");\r
 767                  call move (410,340);\r
 768                  call color(14);\r
 769                  call outstring("< Appuyez sur une touche >");\r
 770                  i := 0;\r
 771                  pref mouse block\r
 772                  begin\r
 773                  do\r
 774                    if driver\r
 775                     then\r
 776                        call getpress(0,xm,ym,b,l,r,c);\r
 777                        if l then l := false;\r
 778                                  call setposition(xm+20,ym+20);\r
 779                                  exit fi\r
 780                    fi;\r
 781                    i:=inkey;\r
 782                    if i<>0 then exit fi\r
 783                  od;\r
 784                  if driver then call hidecursor fi\r
 785                  end;\r
 786                  call hpage(0,0,0);\r
 787     end\r
 788     end start_game;\r
 789   end arbitre;\r
 790 \r
 791 (* STRATEGIE COMMUNE AUX DEUX JOUEURS : ATTAQUE OU DEFENSE IMMEDIATE *)\r
 792  \r
 793   UNIT STRATEGIE : procedure(output priorite : boolean);\r
 794     var nb_flag,i    : integer,\r
 795         lig          : ligne,\r
 796         poss1, poss2 : poss;\r
 797   begin\r
 798     if MDJ.premier then poss1 := jeu1;\r
 799                     poss2 := jeu2\r
 800                else poss1 := jeu2;\r
 801                     poss2 := jeu1\r
 802     fi;\r
 803     priorite := false;\r
 804     lig := poss1.tactik;\r
 805     do\r
 806       if lig = NONE then exit fi;\r
 807       nb_flag := 0;\r
 808       for i:=1 to 3\r
 809         do if lig.occur(i).flag then nb_flag := nb_flag+1 fi\r
 810         od;\r
 811       if nb_flag = 2\r
 812         then for i := 1 to 3\r
 813                do if not lig.occur(i).flag then exit fi\r
 814                od;\r
 815              if MDJ.disponible(lig.occur(i).no)\r
 816                then priorite := true;\r
 817                     clic := lig.occur(i).no;\r
 818                     exit\r
 819              fi\r
 820       fi;\r
 821       lig := lig.suiv\r
 822     od;\r
 823     if not priorite\r
 824       then\r
 825         lig := poss2.tactik;\r
 826         call listdef.delliste;\r
 827         do\r
 828           if lig = NONE then exit fi;\r
 829           nb_flag := 0;\r
 830           for i:=1 to 3\r
 831             do if lig.occur(i).flag then nb_flag := nb_flag+1 fi od;\r
 832           if nb_flag = 2\r
 833             then\r
 834               for i := 1 to 3\r
 835                 do\r
 836                   if not lig.occur(i).flag then exit fi\r
 837                 od;\r
 838                  if MDJ.disponible(lig.occur(i).no)\r
 839                    then\r
 840                         priorite := true;\r
 841                         clic := lig.occur(i).no;\r
 842                         exit\r
 843                    else call listdef.ajout(lig.occur(i).no-10);\r
 844                  fi\r
 845           fi;\r
 846           lig := lig.suiv\r
 847         od\r
 848     fi\r
 849   end strategie;\r
 850  \r
 851 (* STRATEGIE D'ATTAQUE DU JOUEUR 1 *)\r
 852 \r
 853   UNIT STRAT1 : coroutine;\r
 854     var trouve,priorite         : boolean,\r
 855         i, j, k, max, imax, min : integer;\r
 856  \r
 857   begin\r
 858     pref mouse block\r
 859     begin\r
 860       if driver then clic := mousepos\r
 861                 else read(clic)\r
 862       fi\r
 863     end;\r
 864     return;\r
 865     do\r
 866       call strategie(priorite);\r
 867       if not priorite then\r
 868          call majtop(topcoups1);\r
 869          for i := 29 downto 1\r
 870            do if ((topcoups1(i) > max) and (not listdef.member(i)))\r
 871                then\r
 872                  max := topcoups1(i);\r
 873                  imax := i;\r
 874                  trouve := true;\r
 875              fi;\r
 876            od;\r
 877            if trouve\r
 878              then clic := imax\r
 879              else min := 30;\r
 880                   for i := 1 to 3\r
 881                     do for j := 1 to 3\r
 882                          do\r
 883                            if ((dispo(i,j) < min) and (dispo(i,j) > 0))\r
 884                              then min := dispo(i,j)\r
 885                            fi\r
 886                          od\r
 887                     od;\r
 888                   clic := min\r
 889            fi\r
 890       fi;\r
 891       call MDJ.solutions(clic);\r
 892       call majjeu(jeu1);\r
 893       call int_coord(clic, i, j, k);\r
 894       max := MDJ.majcube(i, j, k, MDJ.premier);\r
 895       detach\r
 896     od\r
 897   end strat1;\r
 898 \r
 899 (* STRATEGIE DE DEFENSE DU JOUEUR 2 *)\r
 900 \r
 901   UNIT STRAT2 : coroutine;\r
 902     var trouve, priorite   : boolean,\r
 903         i, j, k, max, imax : integer;\r
 904  \r
 905   begin\r
 906     pref mouse block\r
 907     begin\r
 908       if driver then clic := mousepos\r
 909                 else read(clic)\r
 910       fi\r
 911     end;\r
 912     return;\r
 913     do\r
 914       call strategie(priorite);\r
 915       if not priorite then\r
 916          call majtop(topcoups1);\r
 917          for i := 29 downto 1\r
 918            do if ((topcoups1(i) > max) and (not listdef.member(i)))\r
 919                then\r
 920                  max := topcoups1(i);\r
 921                  imax := i;\r
 922                  trouve := true\r
 923              fi;\r
 924            od;\r
 925            if trouve\r
 926              then clic := imax\r
 927                else max := 1;\r
 928                   for i := 1 to 3\r
 929                     do for j := 1 to 3\r
 930                          do\r
 931                            if dispo(i,j) > max\r
 932                              then max := dispo(i,j)\r
 933                            fi\r
 934                          od\r
 935                     od;\r
 936                   clic := max\r
 937            fi\r
 938       fi;\r
 939       call MDJ.solutions(clic);\r
 940       call majjeu(jeu2);\r
 941       call int_coord(clic, i, j, k);\r
 942       max := MDJ.majcube(i, j, k, MDJ.premier);\r
 943       detach\r
 944     od\r
 945   end strat2;\r
 946  \r
 947 (* CAS OU L'UTILISATEUR EST LE JOUEUR 2 *)\r
 948 \r
 949   UNIT USER : coroutine;\r
 950     var i, j, k, max : integer;\r
 951   begin\r
 952     pref mouse block\r
 953     begin\r
 954       if driver then clic := mousepos\r
 955                 else read(clic)\r
 956       fi\r
 957     end;\r
 958     return;\r
 959     pref iiuwgraph block\r
 960     begin\r
 961     do\r
 962       call move(100,320);\r
 963       call outstring("                                                     ");\r
 964       call move(100,320);\r
 965       call color(14);\r
 966       call outstring("Votre choix ? ");\r
 967       do\r
 968         pref mouse block\r
 969         begin\r
 970           if driver then clic := mousepos\r
 971                     else read(clic)\r
 972           fi\r
 973         end;\r
 974         if MDJ.disponible(clic) then exit fi;\r
 975           call erreurclic;\r
 976       od;\r
 977       call move(100,320);\r
 978       call outstring("                                                     ");\r
 979       call MDJ.solutions(clic);\r
 980       call majjeu(jeu2);\r
 981       call int_coord(clic, i, j, k);\r
 982       max := MDJ.majcube(i, j, k, MDJ.premier);\r
 983       detach\r
 984     od\r
 985     end\r
 986   end user;\r
 987 \r
 988 (* DECLARATIONS DES VARIABLES DU PROGRAMME PRINCIPAL *)\r
 989   var dispo      : arrayof arrayof integer,\r
 990       jeu1, jeu2 : poss,\r
 991       topcoups1,\r
 992       topcoups2  : arrayof integer,\r
 993       MDJ        : arbitre,\r
 994       pile_sol   : pile,\r
 995       listdef    : liste,\r
 996       clic, i, b,\r
 997       xm, ym     : integer,\r
 998       nbjoueur,\r
 999       driver, a, l, r, c : boolean;\r
1000 \r
1001 (* TRAITEMENT DES SIGNAUX *)\r
1002   handlers\r
1003       when WIN1  : pref iiuwgraph block\r
1004                    begin\r
1005                    call move(100,325);\r
1006                    call color(4);\r
1007                    call outstring("MA STRATEGIE D'ATTAQUE ETAIT IMPARABLE !");\r
1008                    call color(15);\r
1009                    end;\r
1010                    wind;\r
1011       when WIN2  : pref iiuwgraph block\r
1012                    begin\r
1013                    call move(100,325);\r
1014                    call color(10);\r
1015                    call outstring("MA DEFENSE M'A MEME EMMENE A LA VICTOIRE !!!! ");\r
1016                    call color(15);\r
1017                    end;\r
1018                    wind;\r
1019       when WIN3  : pref iiuwgraph block\r
1020                    begin\r
1021                    call move(80,325);\r
1022                    call color(13);\r
1023                    call outstring\r
1024                    ("Bravo, vous venez de gagner contre un professionnel !!!! ");\r
1025                    call color(15);\r
1026                    end;\r
1027                    wind;\r
1028       when PLEIN : pref iiuwgraph block\r
1029                    begin\r
1030                    call move(100,325);\r
1031                    call color(15);\r
1032                    call outstring("Le cube est plein, aucun joueur n'a gagn\82");\r
1033                    end;\r
1034                    wind;\r
1035   end handlers;\r
1036  \r
1037 begin (* MAIN *)\r
1038   write(chr(27),"[2J");\r
1039   pref iiuwgraph block\r
1040   begin\r
1041   pref mouse block\r
1042     begin\r
1043       call gron(5);\r
1044       driver := init(b);\r
1045       call init_graph;\r
1046       call move (210,150);\r
1047       call color(3);\r
1048       call outstring("M O R P I O N      3 D");\r
1049       call move(20,250);\r
1050       call color(13);\r
1051       call outstring("Voulez-vous jouer avec l'ordinateur (o/n) ?");\r
1052       b := inchar;\r
1053       if b = 111 then nbjoueur := false;\r
1054                       call color(2);\r
1055                       call move(20,270);\r
1056                       call outstring("Vous \88tes le joueur VERT.");\r
1057                       call move(360,340);\r
1058                       call color(14);\r
1059                       call outstring("< Appuyez sur une touche >");\r
1060                       b := 0;\r
1061                       do if driver\r
1062                          then\r
1063                          call getpress(0,xm,ym,b,l,r,c);\r
1064                          if l then l := false;\r
1065                                    call setposition(xm+20,ym+20);\r
1066                                    exit fi\r
1067                          fi;\r
1068                          b:=inkey;\r
1069                          if b<>0 then exit fi\r
1070                       od;\r
1071                  else nbjoueur := true\r
1072       fi;\r
1073       call init_graph;\r
1074   jeu1 := new poss;\r
1075   jeu2 := new poss;\r
1076   array topcoups1 dim (1:29);\r
1077   array topcoups2 dim (1:29);\r
1078   mdj := new arbitre;\r
1079   call mdj.start_game;\r
1080 end\r
1081 end\r
1082 end P3D.\r