program jeuxPuissance4(input, output);
uses crt, graph;
const L = 6;
      C = 7;
      N = 4;
      police =0 ;
      dir = 0;
      size = 1 ;
      fond = 7 ;
      trait = 15;
      sizepion = 4;

type couleur= (blanc, rouge,nulle);
     grille = array[-1..L+1,-1..C+1]of couleur;
     tabChoix = record {pour la machine}
                 nbChoix:integer;
                 elems:array[1..C] of integer;
                 end;

var gd, gm:integer;
    ms,xmax,ymax, pasX,pasY:integer;
    fin : boolean;
    touche:char;
    lg,col:integer;
    finPartie,abondant:boolean;
    g:grille;
    joueur,gagnant:couleur;
    nbCoupsBlanc,nbCoupsRouge:integer;
    choix:integer;
    ch:string;


     procedure ajouterChoix(var p: tabChoix; cl:integer);
     begin
        p.nbChoix:=p.nbChoix+1;
        p.elems[p.nbChoix]:=cl;
     end;


     procedure poserPion(lg,col, x,y:integer;joueur:couleur);
     begin

          case joueur of
          blanc: begin
                      setcolor(15);
                      circle(col*X+X div 2,(lg-1)*Y+Y div 2, X div sizepion);
                      setFillStyle(1,15);
                      FloodFill(col*X+X div 2,(lg-1)*Y+Y div 2, 15);
                 end;
          rouge: begin
                      setcolor(4);
                      circle(col*X+X div 2,(lg-1)*Y+Y div 2, X div sizepion);
                      setFillStyle(1,4);
                      FloodFill(col*X+X div 2,(lg-1)*Y+Y div 2, 4);
                      setcolor(15);
                 end;
          end;
     end;

     procedure effacerPion(lg, col,x,y:integer;joueur:couleur);
     begin

          case joueur of
          blanc: begin
                      setcolor(1);
                      circle(col*X+X div 2,(lg-1)*Y+Y div 2, X div sizepion);
                      setFillStyle(1,fond);
                      FloodFill(col*X+X div 2,(lg-1)*Y+Y div 2, 1);
                      setcolor(fond);
                      circle(col*X+X div 2,(lg-1)*Y+Y div 2, X div sizepion);
                      setcolor(15);
                 end;
          rouge: begin
                      setcolor(1);
                      circle(col*X+X div 2,(lg-1)*Y+Y div 2, X div sizepion);
                      setFillStyle(1,fond);
                      FloodFill(col*X+X div 2,(lg-1)*Y+Y div 2, 1);
                      setcolor(fond);
                      circle(col*X+X div 2,(lg-1)*Y+Y div 2, X div sizepion);
                      setcolor(15);
                 end;
          end;
     end;



      function estfile(g:grille;i,j:integer):boolean;

       begin
       estfile := ( (g[i,j-2]= joueur) and (g[i,j-1]=joueur) and (g[i,j+1]=joueur) {and (g[i,j+2]=joueur)}) or
                  ( (g[i-2,j]= joueur) and (g[i-1,j]=joueur) and (g[i+1,j]=joueur) {and (g[i+2,j]=joueur)}) or
                  ( (g[i-2,j-2]=joueur) and (g[i-1,j-1] =joueur) and (g[i+1,j+1]=joueur) {and (g[i+2,j+2]=joueur)}) or
                  ( (g[i+2, j-2]=joueur) and (g[i+1,j-1] =joueur) and (g[i-1,j+1]=joueur) {and (g[i-2,j+2]=joueur)} );
       end;

     procedure jouer(var g:grille;lg,col,x,y:integer;joueur:couleur;choix:integer);
     var i:integer;
         c:integer;
     begin
          g[lg,col]:=joueur;
          case joueur of
          blanc: c:=15;
          rouge: c:=4;
          end;
          case choix of
          1: begin
                  effacerPion(1,col,x,y,joueur);
                  for i:=2 to lg
                  do begin
                     poserPion(i,col,x,y,joueur);
                     delay(100);
                     effacerPion(i,col,x,y,joueur);
                     end;
                  poserPion(lg+1,col,x,y,joueur);
             end;
          2:poserPion(lg+1,col,x,y,joueur);
          end;

     end;

     procedure numeroterGrille(X,Y:integer);
     var i:integer;
         num:string[2];
     begin
          setColor(8);
          for i:= 1 to L do
          begin
               str(L-i+1,num);
               OutTextXY(X div 2,Y div 2+ Y*(i),num);
               end;

          for i:= 1 to C do
          begin
               str(i,num);
               OutTextXY(X +X div 2 + X*(i-1),Y div 2+ Y*(L+1),num);
          end;

     end;

     procedure tracerGrille(pasX,pasY:integer);
     var x0,y0, x1, y1,i:integer;
     begin

          setBkColor(fond);
          setcolor(trait);
          x0:=pasX;y0:=pasY;
          x1:=pasX*(C+1); y1:=pasY;

          for i:=0 to L do
            line(x0,y0+pasY*i,x1,y1+pasY*i);
          x0:=pasX;y0:=pasY;
          x1:=pasX; y1:=pasY*(L+1);
          for i:=0 to C do
            line(x0+pasX*i,y0,x1+pasX*i,y1);
          numeroterGrille(pasX,pasY);
          setcolor(1);
          OutTextXY( 500,460 , 'ESC: pour quitter');
     end;

     function max(a,b:integer):integer;
     begin
          if (a>b) then max:=a else max:=b;
     end;

     procedure tailleFile(g:grille;cl:integer;var lgfb,lgfr:integer);
     var fh,fh1,fh2,i,j:integer;
         trouve:boolean;
     begin
          lg:=0;trouve:=false;
           repeat
                 lg:=lg+1;
                 trouve:=g[lg,cl]<>nulle
           until trouve or (lg=L);
           if (trouve)
           then lg:=lg-1;

           lgfr:=0;lgfb:=0;
           {file horizontale}
           fh1 := 0;i:=cl-1;
           if (g[lg,i]<>nulle)
           then begin
                     fh1:=fh1+1;
                     while ((i>=1) and (g[lg,i] = g[lg,i-1]))
                     do begin
                             i:=i-1;
                             fh1:=fh1+1;
                        end;
                 end;

           fh2:=0; i:=cl+1;
           if (g[lg,i]<>nulle)
           then begin
                     fh2:=fh2+1;
                     while (i<=C) and (g[lg,i] = g[lg,i+1])
                     do begin
                             i:=i+1;
                             fh2:=fh2+1;
                        end;
                 end;

           if (g[lg,cl-1]<>nulle)
           then begin
                     case (g[lg,cl-1]) of
                     blanc: lgfb:=fh1;
                     rouge: lgfr:=fh1;
                     end;
                end ;
           if (g[lg,cl+1]<>nulle)
           then begin
                  if (g[lg,cl-1]=g[lg,cl+1])
                  then begin
                            case (g[lg,cl+1]) of
                            blanc: lgfb:=lgfb+fh2;
                            rouge: lgfr:=lgfr+fh2;
                            end;
                       end
                  else begin
                            case (g[lg,cl+1]) of
                            blanc:  lgfb:=max(lgfb,fh2);
                            rouge:  lgfr:=max(lgfr,fh2);
                            end;
                            {case (g[lg,cl-1]) of
                            blanc:  lgfb:=max(lgfb,fh1);
                            rouge:  lgfr:=max(lgfr,fh1);
                            end;}
                       end;
                end;

           {file verticale}
           fh:=0; i:=lg+1;
           if (g[i,cl]<>nulle)
           then begin
                     fh:=fh+1;
                     while ((i<=L) and (g[i,cl] = g[i+1,cl]))
                     do begin
                             i:=i+1;
                             fh:=fh+1;
                        end;
                     case (g[lg+1,cl]) of
                     blanc: lgfb:=max(fh,lgfb);
                     rouge: lgfr:=max(fh,lgfr);
                     end;
                end;
           {diagonale1}
           fh1 := 0;i:=lg-1;j:=cl-1;
           if (g[i,j]<>nulle)
           then begin
                     fh1:=fh1+1;
                     while ((i>=1) and (j>=1) and (g[i,j] = g[i-1,j-1]))
                     do begin
                             i:=i-1;j:=j-1;
                             fh1:=fh1+1;
                        end;
                 end;

           fh2:=0; i:=lg+1; j:=cl+1;
           if (g[i,j]<>nulle)
           then begin
                     fh2:=fh2+1;
                     while ((i<=L) and (j<=C) and (g[i,j] = g[i+1,j+1]))
                     do begin
                             i:=i+1; j:=j+1;
                             fh2:=fh2+1;
                        end;
                 end;

           if (g[lg-1,cl-1]=g[lg+1,cl+1])
           then begin
                     fh:=fh1+fh2;
                     case (g[lg+1,cl+1]) of
                     blanc: lgfb:=max(fh,lgfb);
                     rouge: lgfr:=max(fh,lgfr);
                     end;
                end
           else begin
                     case (g[lg+1,cl+1]) of
                     blanc: lgfb:=max(fh2,lgfb);
                     rouge: lgfr:=max(fh2,lgfr);
                     end;
                     case (g[lg-1,cl-1]) of
                     blanc: lgfb:=max(fh1,lgfb);
                     rouge: lgfr:=max(fh1,lgfr);
                     end;
                end;

           {diagonale2}
           fh1 := 0;i:=lg+1;j:=cl-1;
           if (g[i,j]<>nulle)
           then begin
                     fh1:=fh1+1;
                     while ((i<=L) and (j>=1) and (g[i,j] = g[i+1,j-1]))
                     do begin
                             i:=i+1;j:=j-1;
                             fh1:=fh1+1;
                        end;
                 end;

           fh2:=0; i:=lg-1; j:=cl+1;
           if (g[i,j]<>nulle)
           then begin
                     fh2:=fh2+1;
                     while ((i>=1) and (j<=C) and (g[i,j] = g[i-1,j+1]))
                     do begin
                             i:=i-1; j:=j+1;
                             fh2:=fh2+1;
                        end;
                 end;
           if (g[lg-1,cl+1]=g[lg+1,cl-1])
           then begin
                     fh:=fh1+fh2;
                     case (g[lg-1,cl+1]) of
                     blanc: lgfb:=max(fh,lgfb);
                     rouge: lgfr:=max(fh,lgfr);
                     end;
                end
           else begin
                     case (g[lg-1,cl+1]) of
                     blanc: lgfb:=max(fh2,lgfb);
                     rouge: lgfr:=max(fh2,lgfr);
                     end;
                     case (g[lg+1,cl-1]) of
                     blanc: lgfb:=max(fh1,lgfb);
                     rouge: lgfr:=max(fh1,lgfr);
                     end;
                end;

     end;

     procedure choisirCaseMachine(var col:integer;joueur:couleur; pasX,pasY:integer;g:grille;var abondant:boolean);
     var cl, colBMax,colRMax, lgfb,lgfr ,lgfBMax,lgfRMax: integer;
         pcb,pcr:tabChoix;
     begin
          pcb.nbChoix:=0;pcr.nbChoix:=0;
          lgfb:=0;lgfr:=0;lgfBMax:=0; lgfRMax:=0; colBMax:=1; colRMax:=1;
          cl:=1;
          while(cl<=C) do
          begin
             tailleFile(g,cl,lgfb,lgfr);
             if (lgfb > lgfBMax)
             then begin
                    pcb.nbChoix:=0;
                    ajouterChoix(pcb,cl);
                    lgfBMax:=lgfb;
                  end
             else if (lgfb=lgfBMax)
                  then ajouterChoix(pcb,cl);

             if (lgfr > lgfRMax)
             then begin
                    pcr.nbChoix:=0;
                    ajouterChoix(pcr,cl);
                    lgfRMax:=lgfr;
                  end
             else if (lgfr=lgfRMax)
                  then ajouterChoix(pcr,cl);
             cl:=cl+1;
          end;
          colRMax:=pcr.elems[random(pcr.nbChoix)+1];
          colBMax:=pcb.elems[random(pcb.nbChoix)+1];
          if (lgfRMax=N-1)
          then col := colRMax
          else if (lgfBMax= N-1)
               then col := colBMax
               else if (lgfRMAX = N-2)
                    then col:=colRMax
                    else if (lgfBMax = N-2)
                         then col :=colBMax
                         else if (lgfRMax = N-3)
                              then col:=colRMax
                              else if (lgfBMAX= N-3)
                                   then col:=colBMax
                                   else col := random(C)+1;
     end;

     procedure choisirCaseHumain(var col:integer;joueur:couleur; pasX,pasY:integer;g:grille;var abondant:boolean);
     var fin:boolean;
         touche:char;
     begin
          fin := false;
          col:= C div 2;
          poserPion(1, col,pasX,pasY,joueur);
          repeat
                touche:= readkey;
                case ord(touche) of
                75: begin {gauche}
                          if(col<>1) then
                          begin
                               effacerPion(1,col,pasX,pasY,joueur);
                               col:=col-1;
                               poserPion(1, col,pasX,pasY,joueur);
                          end;
                    end;
                77: begin {droite}
                          if(col<>C) then
                          begin
                               effacerPion(1,col,pasX,pasY,joueur);
                               col:=col+1;
                               poserPion(1,col,pasX,pasY,joueur);
                          end;
                    end;

                32: begin {valider}
                          fin:=true;
                          effacerPion(1,col,pasX,pasY,joueur);
                    end;
                27: begin
                         abondant:=true;
                         fin:=true;
                    end;
                end;

          until fin;
     end;


     procedure initGrille(var g:grille);
      var i, j: integer;
     begin
          for i:=-1 to L+1 do
              for j:=-1 to C+1 do
                  g[i,j]:= nulle;
     end;

     function rechercherLigne(g:grille;col:integer):integer;
     var lg:integer;
          trouve:boolean;
     begin
      lg:=0;trouve:=false;
      repeat
           lg:=lg+1;
           trouve:=g[lg,col]<>nulle
      until trouve or (lg=L);
      if (trouve)
      then rechercherLigne:=lg-1
      else rechercherLigne:=L;
     end;

     function coupvalideBlanc(lg,col:integer;g:grille;nbCoupsBlanc:integer): boolean;
     begin
      if (lg=0)
      then coupValideBlanc:=false
      else if(lg=L)
           then coupValideBlanc := (g[lg,col]=nulle)
           else if (nbCoupsBlanc>0)
                then coupValideBlanc:= ((g[lg,col]=nulle) and (g[lg+1,col]<>nulle))
                else coupValideBlanc:= (lg=L);
     end;

     function coupValideRouge(lg,col:integer;g:grille;nbCoupsrouge:integer): boolean;
     begin
      if(lg=L)
      then coupValideRouge := (g[lg,col]=nulle)
      else if (nbCoupsBlanc>0)
           then coupValideRouge:= ( (g[lg,col]=nulle) and (g[lg+1,col]<>nulle))
           else coupValideRouge:= (lg=L);
     end;



     function testerFinPartie(g:grille;nbCb,nbCr:integer;joueur:couleur):boolean;
     var i,j:integer;
         fin:boolean;
     begin
          fin:=false;{(nbCb+nbCr= L*C);}
          if (not fin)
          then begin
                    i:=1;
                    while (not fin and (i <= L)) do
                    begin
                          j:=1;
                          while (not fin and (j<=C)) do
                          begin
                               if(g[i,j]=joueur)
                               then fin := estfile(g,i,j);

                               j:=j+1;
                          end;
                          i:=i+1;
                    end;

               end;
          testerFinPartie:=fin;
     end;

     procedure afficherResultat(gagnant:couleur);
     var c:integer;
     begin
          case joueur of
          blanc: c:=15;
          rouge: c:=4;
          nulle: c:=1;
          end;
          SetTextStyle(police, dir, size);
          setcolor(c);
          case gagnant of
          blanc : OutTextXY(310,460 , 'Blanc  gagne !');
          rouge : OutTextXY(310, 460, 'Rouge  gagne !');
          nulle:  OutTextXY(310,460 , 'Match nul : Quelle partie!');
          end;
     end;


    procedure afficherTexte(joueur:couleur; ch:string);
    VAR c:integer;
    begin
     case joueur of
     blanc: c:=15;
     rouge: c:=4;
     end;
     SetTextStyle(police, dir, size);
     setcolor(c);
     case joueur of
     blanc : OutTextXY( 310,460 , 'Blanc '+ch);
     rouge : OutTextXY(310,460, 'Rouge '+ch);
     end;
    setcolor(15);
    end;

    procedure effacerTexte(joueur:couleur; ch:string);
    begin
     SetTextStyle(police, dir, size);
     setcolor(fond);
     case joueur of
     blanc : OutTextXY(310,460 , 'Blanc '+ch);
     rouge : OutTextXY(310,460, 'Rouge '+ch);
     end;
    setcolor(15);
    end;

     function quiCommence:couleur;
     var choix:integer;
     begin
          randomize;
          choix:=random(2);
          case choix of
          0: quiCommence:=blanc;
          1: quiCommence:=rouge;
          end;
     end;

     function menu:integer;
     var ch:integer;
     begin
       writeln('Pour jouer avec un(e) amie, tapez <1> ?');
       writeln('Pour jouer avec la machine (pion rouge), tapez <2> ?');
       writeln('Pour quiter, tapez <3> ? ');
       write('votre choix ? '); readln(ch);
       menu := ch;
     end;

     procedure jeux(choix:integer);
     begin
     InitGraph(gd,gm,'../BGI');
     xmax:=getmaxx;
     ymax:=getmaxy;
     pasX:=xmax div (C+1);
     pasY:=ymax div (L+2);
     tracerGrille(pasX,pasY);
     initGrille(g);

     finPartie:=false;
     abondant:=false;
     gagnant:=nulle;
     nbCoupsBlanc:=0;
     nbCoupsRouge:=0;
     joueur:=quiCommence;
     afficherTexte(joueur,'commence');
     delay(1000);
     effacerTexte(joueur,'commence');

     repeat

           if(joueur= blanc)
           then begin
                     afficherTexte(joueur,'joue');
                     choisirCaseHumain(col,joueur,pasX,pasY,g,abondant);
                     lg:=rechercherLigne(g,col);
                     if(not abondant and (lg<>0))
                     then begin
                               nbCoupsBlanc:=nbCoupsBlanc+1;
                               jouer(g,lg,col,pasX,pasY,joueur,choix);
                               finPartie:=testerFinPartie(g,nbCoupsBlanc,nbCoupsRouge,joueur);
                               if(finPartie)
                               then  gagnant :=blanc
                               else  begin
                                          effacerTexte(joueur,'joue');
                                          joueur:=rouge;
                                     end;
                          end;
                 end
           else  begin
                     afficherTexte(joueur,'joue');
                     case choix of
                     1: choisirCaseHumain(col,joueur,pasX,pasY,g,abondant);
                     2: choisirCaseMachine(col,joueur,pasX,pasY,g,abondant);
                     end;
                     setcolor(1);
                     str(col, ch);
                     outtextxy(10, 10,'==');
                     lg:=rechercherLigne(g,col);
                     if(not abondant and (lg<>0))
                     then begin
                               nbCoupsRouge:=nbCoupsRouge+1;
                               jouer(g,lg,col,pasX,pasY,joueur,choix);

                               finPartie:=testerFinPartie(g,nbCoupsBlanc,nbCoupsRouge,joueur);
                               if(finPartie)
                               then  gagnant :=rouge
                               else  begin
                                          effacerTexte(joueur,'joue');
                                          joueur:=blanc;
                                     end;
                          end;
                 end;
     if (nbCoupsBlanc+nbCoupsRouge= L*C)
     then finPartie:=true;
     until finPartie or abondant;
     if(not(abondant))
     then begin
          effacerTexte(joueur,'joue');
          afficherResultat(gagnant) ;
          readln;
     end;
     CloseGraph;

     end;


begin
     clrscr;
     repeat
     choix:= menu;
     case choix of
     1,2 : jeux(choix);
     3 : fin :=true;
     end;
until fin;

end.