program graphes;

{uses crt;}

var f:text;

const max_sommets:byte=26;
      max_degre:byte=26;
      controle:boolean=false;

type graphe=array[1..26,1..26] of integer;
     polynome=array[0..26] of integer;
     sous_graphe=record
      arete:graphe;
      sommets:array[1..26] of boolean;
     end;

var symmetric,clavier,closed:boolean;
    chaine,nfich:string;
   { dico:array[1..20] of string[5];}
    para:array[0..3] of string[10];
    t:graphe;


function trouve_arc(var g:sous_graphe;var ii,jj:byte):boolean;
var trouve:boolean;
    i,j:byte;
 begin
  trouve:=false;
  i:=0;
  repeat
   inc(i);
   j:=0;
   repeat
    inc(j);
    trouve:=g.sommets[i] and g.sommets[j] and ((g.arete[i,j]>=0) or (g.arete[j,i]>=0));
   until (j=max_sommets) or trouve;
  until (i=max_sommets) or trouve;
{  writeln(trouve);}
  trouve_arc:=trouve;
  ii:=i;
  jj:=j;
 end;

procedure identifie_sommets(var g:sous_graphe;i,j:byte);
 var k:byte;
 begin
  if g.sommets[i] and g.sommets[j]
   then
    begin
     for k:=1 to max_sommets do
      if g.sommets[k] and (k<>i) and ( (g.arete[k,j]>=0) or (g.arete[j,k]>=0)) then
       g.arete[k,i]:=1;
     g.sommets[j]:=false;
    end;
 end;

procedure polynome_chromatique(var p:polynome;var g:sous_graphe);
 var i,j:byte;
       h:sous_graphe;
     q,r:polynome;
  begin
   if trouve_arc(g,i,j)
    then
     begin
      {writeln('arc ',i,' ',j);}
      h:=g;
      h.arete[i,j]:=-1;
      h.arete[j,i]:=-1;
      polynome_chromatique(q,h);
      identifie_sommets(h,i,j);
      polynome_chromatique(r,h);
      for i:=0 to max_degre do p[i]:=q[i]-r[i];
     end
   else
    begin
     j:=0;
     for i:=1 to max_sommets do if g.sommets[i] then inc(j);
{     writeln(j);}
     fillchar(p,sizeof(p),0);
     p[j]:=1;
    end;
  end;



procedure decompose(s:string);
var t:string;
    i,j:byte;
begin
 fillchar(para,sizeof(para),0);
 t:=s+' ';
 i:=0;
 para[0]:=t;
 j:=pos(' ',t);
 while (j<>0) and (i<4) do
  begin
   para[i]:=copy(t,1,j-1);
{   write(para[i],'/');}
   t:=copy(t,j+1,255);
   inc(i);

   j:=pos(' ',t);
  end;
 { writeln;}
end;



function fini:boolean;
 begin
  fini:=(para[0]='fin')
 end;


procedure init(var t:graphe);
 var i,j:byte;
  begin
   for i:=1 to max_sommets do for j:=1 to max_sommets do
   t[i,j]:=-1;
  end;

 
    function liste(var t : graphe):boolean;
    var i,j:byte;
        var rs:boolean;
  begin rs:=(para[0]='liste');
  if not rs then
   liste:=false
  else
  begin
     liste:=true;
   for i:=1 to max_sommets do for j:=1 to max_sommets do
   if t[i,j]>0 then writeln('(',chr(64+i),',',chr(64+j),'):',t[i,j]);
     end;
     
  end; { liste }

procedure arc(var t:graphe;i,j,l:byte);
 begin
  if (i>0) and (j>0) and (i<=max_sommets) and (j<=max_sommets)
  then
   begin
    t[i,j]:=l;
    if symmetric then  t[j,i]:=l;
   end;
 end;


procedure cherche(var t:graphe;nb_sommets,entree,sortie:byte);
 var c:array[1..26] of integer;
     final,p:array[1..26] of byte;
     j,meilleur:byte;
     essai,score:integer;
     first,err:boolean;

const debut:byte=0;
      transitoire:byte=1;
      definitif:byte=2;

procedure chem(i:byte);
begin
 if i<>entree  then chem(p[i]);
 write(' ',chr(64+i));
end;

 begin {procedure}

{ initialisation }
{  writeln(entree, ' ',sortie); }
  err:=false;
  for j:=1 to nb_sommets do
   begin
    c[j]:=-1;
    final[j]:=debut;
   end;
  c[entree]:=0;
  final[entree]:=definitif;
  meilleur:=entree;

 while meilleur<>sortie do
   begin {while}

    for j:=1 to nb_sommets do
     if t[meilleur,j]>=0
      then

      begin {if }

       essai:=c[meilleur]+t[meilleur,j];
       if (c[j]<0) or (essai<c[j]) then
        begin {if}
         c[j]:=essai;
         p[j]:=meilleur;
         final[j]:=transitoire;
      {   writeln(meilleur,' ',j,' * ',final[2]); }
        end; {end if}

      end; {end if}
    {  for j:=1 to nb_sommets do write(final[j],' ');}
      first:=true;
      for j:=1 to nb_sommets do
       if (final[j]=transitoire)
        then
         begin {test état transitoire}
         { writeln('c ',j); }
          if  ((c[j]<score) or first)
            then
             begin {if recherche meilleur}
             { writeln('candidat: ',j);}
              first:=false;
              score:=c[j];
              meilleur:=j;
             end; {if recherche meilleur}
         end; {test état transitoire }
      if first then
       begin {erreur}
        writeln('Pas de chemin ');
        err:=true;
        meilleur:=sortie;
       end; {erreur}
      final[meilleur]:=definitif;
      {writeln(meilleur);}
    end; {while}
  if not err
   then
    begin
     chem(sortie);
     writeln;
    end;
 end; {procedure}


function cree_arc(var t:graphe):boolean;
 var rs:boolean;
      i,j,l:shortint;
      dummy:word;
 begin
  rs:=(para[0]='arc');
  if not rs then
   cree_arc:=false
    else
     begin
      i:=ord(para[1][1])-64;
      j:=ord(para[2][1])-64;
      if para[3]='' then l:=1 else val(para[3],l,dummy);
      arc(t,i,j,l);
      if controle then  writeln(i, ' ',j,' ',l);
      cree_arc:=true;
     end;
 end;

function chemin(var t:graphe):boolean;
 var rs:boolean;
      i,j:shortint;
 begin
  rs:=(para[0]='chemin');
  if not rs then
   chemin:=false
    else
     begin
      i:=ord(para[1][1])-64;
      j:=ord(para[2][1])-64;
      if controle then writeln(i, ' ',j,' ');
      writeln(' Je cherche...');
      cherche(t,26,i,j);
      chemin:=true;
     end;

 end;

FUNCTION NORMAL(L:REAL):STRING;
VAR    S:STRING;
    TEST:BOOLEAN;
 BEGIN

  STR(L:15:5,S);  { CONVERTIR EN CHAINE }

  WHILE COPY(S,1,1)=' ' DO DELETE(S,1,1); {ENLEVER LES ESPACES }

   IF POS('.',S)<>0 THEN {ENLEVER LES ZEROS APRES LA VIRGULE}
    BEGIN
      REPEAT
       TEST:=(COPY(S,LENGTH(S),1)='0');
       IF TEST OR (COPY(S,LENGTH(S),1)='.') THEN DELETE(S,LENGTH(S),1);
      UNTIL NOT TEST
    END;
  NORMAL:=S
 END;

Function Degre(p:polynome):integer;
var i:integer;
begin
  i:=max_degre;
  while (i>=0) and (p[i]=0) do i:=i-1;
  if i<0 then i:=-maxint;
  Degre:=i;
end;

function reste(var a,b:polynome;i:integer):integer;
var n:byte;
 begin
  a[max_degre]:=0;
  for n:=max_degre downto 1 do a[n-1]:=b[n]+i*a[n];
  reste:=b[0]+i*a[0];
 end;



FUNCTION ECRITURE_POLY(V:polynome):STRING;
VAR I,D:WORD;
      S:STRING;
 BEGIN
  S:='';
  D:=DEGRE(V);
  FOR I:=D DOWNTO 1 DO IF V[I]<>0 THEN
   BEGIN

    IF V[I]=1 THEN S:=S+'+x'
     ELSE IF V[I]=-1 THEN S:=S+'-x'
     ELSE
     BEGIN
      IF V[I]>0 THEN S:=S+'+';
      S:=S+NORMAL(V[I])+'x'
     END;
    IF I<>1 THEN S:=S+'^'+NORMAL(I);
   END;
  IF (D=0) OR (V[0]<>0) THEN
   BEGIN
    IF V[0]>0 THEN S:=S+'+';
    S:=S+NORMAL(V[0]);
   END;
  IF S[1]='+' THEN DELETE (S,1,1);
  ECRITURE_POLY:=S;
 END;


function chroma(var t:graphe):boolean;
 var rs:boolean;
      i,j,l,d:shortint;
        g:sous_graphe;
        p,q:polynome;
          s:string;
 begin
  rs:=(para[0]='chroma');
  if not rs then
   chroma:=false
    else
     begin
      i:=ord(para[1][1])-64;
      j:=ord(para[2][1])-64;
      if controle then writeln(i, ' ',j,' ');
      writeln(' Je cherche...');
      g.arete:=t;
      for l:=1 to max_sommets do g.sommets[l]:=(l>=i) and (l<=j);
      polynome_chromatique(p,g);
      i:=0;
      repeat
      d:=0;
      while reste(q,p,i)=0 do
       begin
        inc(d);
        p:=q;
       end;
      if d>0 then
              begin if i=0 then
                             begin
                              if d>1 then write('x^',d) else write ('x')
                             end

                              else begin if d>1 then
                              write('(x-',i,')^',d) else
                              write('(x-',i,')') end
              end;
      inc(i);
      until d=0;
      s:=ecriture_poly(p);
      if s<>'1' then writeln('(',s,')');
      chroma:=true;
     end;

 end;

procedure parametre;
var entree:byte;
begin
   for entree:=1 to paramcount do
   begin
      case paramstr(entree)[1] of
    'd' : symmetric:=false;
    'f' : begin
           nfich:=copy(paramstr(entree),3,255);
           clavier:=false;
          end;
     end;
   end;
end; { parametre }


begin
 init(t);
 symmetric:=true;
 clavier:=true;
 closed:=true;
 parametre;
 if not clavier then
  begin
   assign(f,nfich);
   reset(f);
   closed:=false;
  end;
 repeat
  write('>');
  if clavier then readln(chaine)
             else begin readln(f,chaine); write(chaine); end;
  decompose(chaine);
  if cree_arc(t) or chemin(t) or chroma(t) or liste(t) or fini then writeln(' ... OK') else
    begin
     writeln('?');
     if not clavier
      then
       begin clavier:=true; close(f); closed:=true; end;
    end;
 until fini {or eof(f)};
if not closed then close(f);
end.

{ arc(t,1,4,7);
 arc(t,1,2,3);
 arc(t,1,5,1);
 arc(t,4,2,3);
 arc(t,2,5,6);
 arc(t,4,3,5);
 arc(t,2,3,7);
 arc(t,3,5,3);
 cherche(t,26,4,5);
 writeln;
 cherche(t,26,1,5);
end.}
584859