Programme PASCAL pour les graphes

Copyright (gH)

PROGRAM Grundys ; { Hunault, Angers 93 (Heuristique, Licence Maths) }


 (*$I Grundys.Var *) { contient les déclarations des variables
                             et les sous-programmes généraux }
 (*$I Grundys.Inc *) { contient les sous-programmes dédiés aux graphes }

BEGIN ClrScr ;

{ # 1. Initialisations et lecture du fichier des arcs }

   NbNiv      := 0  ; { Niveau courant puis nombre de niveaux }
   NbArc      := 0  ; { Arc    courant puis nombre d' arcs    }
   NbSom      := 0  ; { Sommet courant puis nombre de sommets }
   NbSrestant := 0  ; { nombre de sommets actuellement sans niveaux }
   NomSom     := '' ; { Liste des noms de sommets }

   FichA   := 'Grundys.Arc' ;{ Fichier des Arcs }
   InitVec(LigneT)    ; { Ligne des Totaux }
   InitMat(Connec)    ; { Matrice de connecticité }
   InitLst(Niveau)    ; { Listes liées des éléments par niveaux }
   InitVecAl(NumS)    ; { Numéro des sommets }

   ConstruireMatC ;
      { la matrice de connectivité à partir du fichier des arcs }
   TotalColonne   ;
      { initialise la Ligne des Totaux et nbrestant }

{ # 2. Détermination des niveaux par la méthode de Moucron }

 while nbSrestant > 0 { nombre de Sommets restant } do begin
    SupprimeSetCreeN  { supprime les sommets isolés et crée les niveaux }
 end ; { fintant que nbSrestant > 0 }

{ # 3. Affichages des résultats }

 writeln(' Graphe orienté associé au fichier Grundy.Arc ') ;
 writeln(' avec : ',nbsom,' sommet(s) ',nbarc,' arc(s) ',
           nbniv,' niveau(x) ') ;
 affMconnec ;
 repeat until keypressed

END.

Contenu du FichiersInclus

{ Grundys.Var pour Grundys.Pas }
Uses  Dos, Crt ;
Const Nbelt = 100 ;
Type  Vec   = Array[1..Nbelt] of Integer ;
      VecAl = Array[1..Nbelt] of String[3] ; { Al comme Alpha }
      Mat   = Array[1..Nbelt,1..Nbelt] of Integer ;
      Ll    = Array[1..NbElt,1..NbElt] of String[3] ;
Var   NbNiv,NbArc,NbSom,NbSrestant : integer ;
      FichArc : Text ; FichA : String ;
      NoMSom : string ;
      LigneT : Vec ; NumS : VecAl ;
      Connec : Mat ;
      Niveau : Ll  ;

Procedure InitVec(var vecLig:Vec)  ;
 var ind : integer ;
Begin
  for ind := 1 to nbelt do begin
      vecLig[ind] := 0
  end
End ;

Procedure InitVecAl(var vecLigAl:VecAl)  ;
 var indAl : integer ;
Begin
  for indAL := 1 to nbelt do begin
      vecLigAl[indAl] := ''
  end
End ;

Procedure InitMat(var Cnec:Mat)  ;
 var indl,indc : integer ;
Begin
  for indl := 1 to nbelt do begin
      for indc := 1 to nbelt do begin
           Cnec[indl,indc] := 0
      end
  end
End ;

function ecritniveau( n : integer) : string ;
 var indniv : integer ; sort : string ;
begin
   indniv := 1 ;
   sort := '' ;
   while niveau[n,indniv] <> '?' do begin
     sort := sort + ' ' + niveau[n,indniv] ;
     inc(indniv)
   end ;
   ecritniveau := sort
end ;

procedure LesNiveaux ;
  var son : integer ;
begin
    for son := 1 to nbelt do begin
        writeln(' niveau ',son,' ' , ecritniveau(son) )
    end
end ;

Procedure InitLst(var niv : ll ) ;
 var indn,indel : integer ;
Begin
     for indn := 1 to Nbelt do begin
         for indel := 1 to Nbelt do begin
             niv[indn,indel] := '?'
         end
     end
End ;



 procedure decoupe(phr : string ; var preum,deuze : string ) ;
   { découpe la phrase en deux mots }
   var indcar : integer ; longn : integer ; deb,fin : integer ;
 begin
   phr := phr + ' ? ?? ' ;
   longn := length(phr) ;
   indcar := 1 ;
   while phr[indcar] =  ' ' do begin
      inc(indcar) ; deb := indcar
   end ;
   while phr[indcar] <> ' ' do begin
      inc(indcar) ; fin := indcar
   end ;
   preum := copy(phr,deb,fin-deb) ;
   while phr[indcar] =  ' ' do begin
      inc(indcar) ; deb := indcar
   end ;
   while phr[indcar] <> ' ' do begin
      inc(indcar) ; fin := indcar
   end;
   deuze:= copy(phr,deb,fin-deb)
 end ;

function NumSom(a:string ; b : string ) : integer ;
 var i : integer ; im, l : integer ; d,f : integer ; mot : string ;
begin
 i := 1 ;
 im := 0 ;
 b := ' ' + b + a + '??? ' ; { garantit que la recherche aboutira }
 l := length(b) ;
 while i <= l do begin
   while b[i] =  ' ' do begin
         inc(i) ; d := i ; inc(im)
   end ;
   while b[i] <> ' ' do begin
         inc(i) ; f := i ; mot := copy(b,d,f-d)
   end ;
   if mot = a then begin
      numsom := im ;
      i := l+1
   end  { fin du if mot = a }
 end  { fin du while i <= l }
end ;

function poslibre( nv : integer ) : integer ;
  var iv : integer ;
begin
  iv := 1 ;
  while niveau[nv,iv] <> '?' do begin
        inc(iv)
  end ;
  poslibre := iv
end ;

procedure affLignet ;
 var s : integer ;
begin
 write( ' niveau ', nbniv, ' : ') ;
 for s:=1 to nbsom do begin
    write( lignet[s]:3)
 end
end ;

procedure affMconnec ;
 { affiche la matrice de connecticité et les niveaux }
  var s,so,sd : integer ; nso : String[5] ;
begin
 write( '   ' ) ;
 for s:=1 to nbsom do write(' ',nums[s],' ' ) ;
 writeln( '      Niveaux ') ;
 for so:=1 to nbsom do begin
    nso := nums[s] ;
    write( nso, ' ' ) ;
    for sd:=1 to nbsom do begin
       if connec[so,sd] = 1
          then write(  ' 1 ' )
          else write(  '   ' )
    end ;
    if so <= nbniv
       then writeln( '     ' , so:3, ' : ', ecritniveau(so) )
       else writeln
 end
end ;

procedure ConstruireMatC ;
 { la matrice de connectivité à partir du fichier des arcs }
 var lignarc,orig,dest : string ; norig, ndest : integer ;
begin
  (*$I-*)
  assign(ficharc,ficha) ;   reset(ficharc) ;
  if ioresult<>0 then begin
     writeln(' Problème d''ouverture du fichier ', ficha) ;
     writeln(' Appuyer sur une touche pour terminer ') ;
     readln ; halt { fin brutale }
  end ;
  nbarc := 0 ;
  while not eof(ficharc) do begin
       readln(ficharc,lignarc) ; decoupe(lignarc,orig,dest) ;
       nbarc := nbarc  + 1 ;
       if pos(orig,nomsom) = 0 then begin
          nbsom  := nbsom + 1 ;
          nomsom := nomsom + ' ' + orig + ' ' ;
          nums[nbsom] := orig
       end ;
       if pos(dest,nomsom) = 0 then begin
          nbsom  := nbsom + 1 ;
          nomsom := nomsom + ' ' + dest + ' ' ;
          nums[nbsom] := dest
       end ;
       norig := numSom(orig,nomsom) ; ndest := numSom(dest,nomsom) ;
       connec[norig,ndest] := 1
  end
end ;

procedure   TotalColonne ; { initialise la Ligne des Totaux et NbSrestant }
 var so,sd : integer ; somcol : integer ;
begin
 if nbniv = 0 then nbSrestant := nbsom
 for so := 1 to nbsom do begin
     somcol := 0 ;
     for sd := 1 to nbsom do begin
         if connec[sd,so] = 1 then somcol := somcol + connec[sd,so]
     end ;
 lignet[so] := somcol
 end
end ;

procedure   SupprimeSetCreeN ;
 { supprime les sommets isolés et crée les niveaux }
 var totc : vec ; s,sc,ps : integer ;
begin
 nbniv := nbniv + 1 ;
 initvec(totc) ;
 for s := 1 to nbsom do begin
     if lignet[s] = 0 then begin
         ps := poslibre(nbniv) ;
         niveau[nbniv,ps] := nums[s] ;
         for sc := 1 to nbsom do begin
             if connec[s,sc] = 1 then totc[sc] := totc[sc] + 1
         end ;
         nbSrestant := nbSrestant - 1 ;
         lignet[s] := -1
      end { fin de si }
 end ; { fin de pour }
 for s := 1 to nbsom do begin
     lignet[s] := lignet[s] - totc[s]
 end
end ;