Langage déclaratif 
pour définir récursivement un graphe orienté
et programme de recherche dans le graphe.

Version du 30.05.2005

Auteur: Marcel Délèze, Collège du Sud, CH - 1630 Bulle
Tous droits réservés

BeginPackage["ExplorateurDeGraphes`"];

Description du graphe

debut

debutDeclaration::usage=
	"debutDeclaration[] doit être exécuté avant les déclarations des arcs et des arêtes.";

arc::usage=
	"arc[ndDpt, ndArr] déclare le nouvel arc\n     ndDpt ⟶ ndArr\nou l'arc universel\n     ndDpt:var ⟶ ndArr(ndDpt).";

arcConditionnel::usage=
	"arcConditionnel[ndDpt, ndArr, condQ] déclare l'arc universel conditionnel\n     ndDpt:var ⟶ ndArr(ndDpt)   si   condQ(ndDpt).\narcConditionnel évalue ses arguments de manière non standard.";

arete::usage=
	"arete[ndDpt, ndArr] déclare les deux arcs\n     ndDpt ⟶ ndArr   et    ndArr ⟶ ndDpt\noù ndDpt et ndArr sont des sommets factuels (c'est-à-dire des constantes).\nPour définir une arête universelle, il faut déclarer explicitement deux arcs :\n     arc[ndDpt, ndArr, cond1Q]; arc[ndArr, ndDpt, cond2Q].";

barriereQ::usage=
	"barriereQ est une fonction dont la valeur est True pour tous les sommets à exclure et False pour les sommets valides.\nAvant de définir une barrière, il faut d'abord effacer la barrière par défaut\n     Clear[barriereQ]; barriereQ[nd_]:= ...\nbarriereQ est appliquée à tous les sommets.";

finDeclaration::usage=
	"finDeclaration[] doit être exécuté avant la première recherche.";

Fonctions de recherche

succ::usage=
	"succ[nd] produit la liste des successeurs directs du sommet nd.";

pred::usage=
	"pred[nd] produit la liste des prédécesseurs directs du sommet nd. Cette fonction est restreinte aux sommets factuels (c'est-à-dire déclarés dans un arc ordinaire).";

sommetPropriete::usage=
	"ndDpt désignant un sommet ou une liste de sommets, sommetPropriete[ndDpt, proprQ] retourne les descendants de ndDpt qui vérifient la propriété proprQ à la profondeur d'arrêt.";

ensembleSommetsPropriete::usage=
	"ndDpt désignant un sommet ou une liste de sommets, ensembleSommetsPropriete[ndDpt, proprQ] retourne l'ensemble des descendants de ndDpt qui vérifient la propriété proprQ.\nensembleSommetsPropriete[ndDpt, proprQ, prof] retourne l'ensemble des descendants de ndDpt qui vérifient la propriété proprQ jusqu'à la profondeur de recherche prof.";

ensembleDescendants::usage=
	"ndDpt désignant un sommet ou une liste de sommets, ensembleDescendants[ndDpt] retourne l'ensemble des descendants de ndDpt, y compris ndDpt.\nensembleDescendants[ndDpt, prof] retourne l'ensemble des descendants de ndDpt jusqu'à la profondeur de recherche prof, y compris ndDpt.";

cheminCourant::usage=
	"Si nd est un sommet, cheminCourant[nd] donne un chemin qui aboutit au sommet nd. Le chemin est déterminé selon l'état courant de l'arbre de recherches après sommetPropriete, ensembleSommetsPropriete ou ensembleDescendants. Si nd est une liste de sommets, cheminCourant est appliqué à chaque sommet de la liste.";

cheminSimple::usage=
	"cheminSimple[r, butQ, longMax] retourne un chemin simple dont le début est r et qui est progressivement rallongé jusqu'à ce que le chemin r vérifie la propriété butQ ou qu'il n'y ait plus de sommet disponible ou que la longueur maximale soit atteinte.\ncheminSimple[r, butQ] équivaut à cheminSimple[r, butQ, Infinity].";

ensembleCheminsSimples::usage=
	"ensembleCheminsSimples[r, butQ, longMax] retourne l'ensemble des chemins dont le début est r, qui vérifient la propriété butQ et dont la longueur est au plus longMax.\nensembleCheminsSimples[r, butQ] équivaut à ensembleCheminsSimples[r, butQ, Infinity].";

cheminBalises::usage=
	"cheminBalises[ndDpt, buts] retourne un chemin qui part du sommet ndDpt. La première étape est un chemin vers le sommet le plus proche qui vérifie la propriété buts[[1]]. Le chemin est prolongé vers le sommet le plus proche qui vérifie la propriété buts[[2]]; etc. (chemin avec balises)";

descenteForte::usage=
	"descenteForte[ndDpt, dist] retourne un chemin qui part du sommet ndDpt et se rapproche progressivement du but (dist est une fonction qui mesure l'éloignement du sommet courant au but final). Le programme effectue une recherche locale jusqu'à ce qu'il trouve des sommets dont la distance au but est inférieure à la distance courante. Parmi eux, il choisit le sommet de distance minimale.";

descenteFaible::usage=
	"descenteFaible[ndDpt, dist] retourne un chemin qui part du sommet ndDpt et se rapproche progressivement du but (dist est une fonction qui mesure l'éloignement du sommet courant au but final). Le programme effectue une recherche locale jusqu'à ce qu'il trouve des sommets dont la distance au but est inférieure à la distance courante. Parmi eux, il choisit le sommet de distance maximale.";

Fonctions booléennes

terminalQ::usage=
	"terminalQ[nd] retourne la valeur True si le sommet nd est terminal (c'est-à-dire ne possède aucun successeur) et False dans les autres cas.";

racineQ::usage=
	"racineQ[nd] retourne la valeur est True si nd est une racine factuelle (c'est-à-dire déclarée dans un arc ordinaire) et False dans les autres cas.";

egalQ::usage=
	"egalQ[nd] est fonction définie pour chaque noeud et dont la valeur est True si le noeud est égal à nd.";

membreQ::usage=
	"membreQ[{n1, ..., nk}] est fonction définie pour chaque sommet et dont la valeur est True si le sommet appartient à la liste {n1, ..., nk}.";

cycleQ::usage=
	"cycleQ[n] est fonction définie pour chaque chemin et dont la valeur est True si le chemin est un cycle de longueur n.";

longueurQ::usage=
	"longueurQ[n] est fonction définie pour chaque chemin et dont la valeur est True si la longueur du chemin est n.";

inclusQ::usage=
	"inclusQ[a, b] est fonction dont la valeur est True si l'ensemble a est inclus dans l'ensemble b.";

passeParQ::usage=
	"passeParQ[a] est fonction définie pour chaque chemin et dont la valeur est True si la liste a (formée de sommets) est incluse dans le chemin.";

sousGrapheQ::usage=
	"sousGrapheQ[g] est fonction définie pour chaque chemin et dont la valeur est True si le chemin est inclus dans la liste de sommets g.";

Autres fonctions

racinesGraphe::usage=
	"racinesGraphe[] retourne la liste des racines factuelles (c'est-à-dire déclarées dans un arc ordinaire).";

dernierSommet::usage=
	"dernierSommet[fQ_] applique la fonction fQ au dernier sommet du chemin.";

chaqueSommet::usage=
	"chaqueSommet[fQ_] applique la fonction fQ à tous les sommets d'un chemin r: fQ[r[[1]]]∧fQ[r[[2]]]∧...∧fQ[r[[k]]].";

profondeur::usage=
	"profondeur[] retourne la profondeur dans l'arbre des visites lors de la dernière recherche.\nprofondeur[p] fixe la profondeur maximale à p pour les recherches ultérieures.\nLa profondeur maximale par défaut est de 64.";

cout::usage=
	"cout[] retourne le nombre de sommets visités lors de la dernière recherche.";

enLignes::usage=
	"enLignes[t] affiche la liste de listes t en un tableau.";

enColonnes::usage=
	"enColonnes[t] affiche la liste de listes t en un tableau transposé.";

maxFct::usage=
	"maxFct[d_List, f] retourne un maximum de la fonction f sur le domaine d.";

minFct::usage=
	"minFct[d_List, f] retourne un minimum de la fonction f sur le domaine d.";

Implémentation

Begin["`Private`"];

arc::liste="Un noeud ne peut pas être de type List.";

arc::arg="Sont attendus deux arguments.";

arcConditionnel::arg="Sont attendus trois arguments.";

arcConditionnel::nonUniversel="Le premier argument doit contenir au moins une variable universelle x_.";

sommetPropriete::profMax=
	"La profondeur maximale de `1` a été atteinte.";

sommetPropriete::nonBooleen="Le but doit être une fonction qui, lorsqu'elle est appliquée à un sommet, doit valoir True ou False.";

ensembleSommetsPropriete::nonEntier="Le troisième argument doit être un entier ou Infinity.";

ensembleSommetsPropriete::arg="Sont attendus 2 ou 3 arguments.";

cheminSimple::arg="Sont attendus deux ou trois arguments dont le premier de type List.";

cheminSimple::nonEntier="Le troisième argument doit être un entier ou Infinity.";

cheminSimple::nonBooleen="Le deuxième argument est une fonction qui, appliquée à un chemin, doit valoir True ou False.";

ensembleCheminsSimples::arg="Sont attendus deux ou trois arguments dont le premier de type List.";

ensembleCheminsSimples::nonEntier="Le troisième argument doit être un entier ou Infinity.";

ensembleCheminsSimples::nonBooleen="Le deuxième argument est une fonction qui, appliquée à un chemin, doit valoir True ou False.";

descenteForte::nonNum="Le deuxième argument doit être une fonction à valeur non négative."

descenteFaible::nonNum="Le deuxième argument doit être une fonction à valeur non négative."

profondeur::nonEntier=
	"L'argument doit être Infinity ou un entier non négatif.";

pred::nonDef=
	"L'argument n'est pas un sommet factuel.";

Unprotect[debutDeclaration,arc,arcConditionnel,arete,finDeclaration,succ,pred,sommetPropriete,  ensembleSommetsPropriete,ensembleDescendants,  cheminSimple,ensembleCheminsSimples,cheminBalises,descenteForte,descenteFaible,racinesGraphe,egalQ,membreQ,cycleQ,longueurQ,inclusQ,passeParQ,sousGrapheQ,dernierSommet,chaqueSommet,profondeur, cout, terminalQ, racineQ, enLignes, enColonnes,maxFct,minFct]

Clear[pred, succ]

Début algorithme

Description du graphe

debutDeclaration[]:=(Clear[trans,predecesseur,barriereQ,pereVisiteur];nbreRegles=0;niveau=0;barriereQ:=False&;ndDptFactuels={};niveauMax=64;$RecursionLimit=512;collectes={};nbreVisites=0;)

arc[ndDpt_List,___]:=Message[arc::liste]

arc[ndDpt_,ndArr_List,___]:=Message[arc::liste]

arc[noeudDpt_,noeudArr_]:=(Increment[nbreRegles];
trans[nbreRegles][noeudDpt]:=noeudArr;If[Not[universelQ[noeudDpt]],
AppendTo[ndDptFactuels,noeudDpt];
If[Head[predecesseur[noeudArr]]===predecesseur,predecesseur[noeudArr]={noeudDpt},predecesseur[noeudArr]=Union[predecesseur[noeudArr],{noeudDpt}]]
];)

arc[___]:=Message[arc::arg]

arete[x_,y_]:=(arc[x,y];arc[y,x];)

SetAttributes[arcConditionnel,HoldAll];

arcConditionnel[ndDpt_,___]:=Message[arcConditionnel::nonUniversel]/;Not[universelQ[ndDpt]]

arcConditionnel[ndDpt_List,___]:=Message[arc::liste]

arcConditionnel[ndDpt_,ndArr_List,___]:=Message[arc::liste]

arcConditionnel[noeudDpt_,noeudArr_, siQ_]:=(Increment[nbreRegles];
trans[nbreRegles][noeudDpt/;siQ]:=noeudArr;)

arcConditionnel[___]:=Message[arcConditionnel::arg]

finDeclaration[]:=Module[{i},
ndDptFactuels=Union[ndDptFactuels];
ndDptFactuels=Complement[ndDptFactuels,Flatten[Map[successeur[#]&,ndDptFactuels],1]];
Do[predecesseur[ndDptFactuels[[i]]]={},{i,1,Length[ndDptFactuels]}];]

Fonctions de recherche de sommets

pred[x_]:=Message[pred::nonDef]/;Head[predecesseur[x]]===predecesseur

pred[x_]:=predecesseur[x]

successeur[x_]:=Select[Select[Table[trans[j][x],{j,1,nbreRegles}],UnsameQ[Head[Head[#]],trans]&], Not[barriereQ[#]]∧UnsameQ[#,x]&]

succ[x_]:=successeur[x]

nonMarqueQ[nd_]:=SameQ[Head[pereVisiteur[nd]],pereVisiteur];

marquage[pere_,fils_]:=Module[{k},
Do[
pereVisiteur[fils[[k]]]=pere ;PreIncrement[nbreVisites],
{k,1,Length[fils]}]]

rechercheRecursiveSommet[niv_,but_]:=Module[{v,ns,suivants,j,aMarquer},
v=Select[niv,but];
If[UnsameQ[v,{}],Return[v]];
If[niveau≥niveauMax,Message[sommetPropriete::profMax, niveauMax];Return[{}]];
ns=Union[Flatten[
Table[
suivants=successeur[niv[[j]]];
aMarquer=Select[suivants,nonMarqueQ];
marquage[niv[[j]],aMarquer];
aMarquer,
{j,1,Length[niv]}]]];
If[SameQ[ns,{}],{},PreIncrement[niveau];rechercheRecursiveSommet[ns,but]]]

sommetPropriete[ndDpt_,butQ_,___]:=Message[sommetPropriete::nonBooleen]/;Not[MemberQ[{True,False},butQ[First[Flatten[{ndDpt}]]]]]

sommetPropriete[ndDpt_,butQ_]:=Module[{depart,j},
niveau=0;Clear[pereVisiteur];
depart=Flatten[{ndDpt}];
nbreVisites=0;marquage[nil,depart];
Union[rechercheRecursiveSommet[depart,butQ]]
]

rechercheRecursiveCollecte[niv_,butQ_, prof_]:=Module[{ns,suivants,j,aMarquer},
If[niveau≥prof,Throw[Null],
If[niveau≥niveauMax,Message[cheminPropriete::profMax, niveauMax];Return[collectes]];
ns=Union[Flatten[
Table[
suivants=successeur[niv[[j]]];
aMarquer=Select[suivants,nonMarqueQ];
marquage[niv[[j]],aMarquer];
collectes=Join[collectes,Select[aMarquer,butQ]];
aMarquer,
{j,1,Length[niv]}]]];
If[SameQ[ns,{}],{},PreIncrement[niveau];rechercheRecursiveCollecte[ns,butQ, prof]]]]

ensembleSommetsPropriete[ndDpt_,butQ_, prof_]:=Message[sommetPropriete::nonBooleen]/;Not[MemberQ[{True,False},butQ[First[Flatten[{ndDpt}]]]]]

ensembleSommetsPropriete[ndDpt_,butQ_, prof_]:=Message[ensembleSommetsPropriete::nonEntier]/;Not[IntegerQ[prof] ∨ SameQ[prof,Infinity]]

ensembleSommetsPropriete[ndDpt_,butQ_, prof_]:=Module[{depart,parcours,j,nd,precedent, rep},
niveau=0;depart=Flatten[{ndDpt}];
collectes=Select[depart,butQ];Clear[pereVisiteur];
nbreVisites=Length[depart]; marquage[nil, depart];
Catch[rechercheRecursiveCollecte[depart,butQ,prof]];
collectes];

ensembleSommetsPropriete[ndDpt_,butQ_]:=ensembleSommetsPropriete[ndDpt, butQ, Infinity]

ensembleSommetsPropriete[___]:=Message[ensembleSommetsPropriete::arg]

ensembleDescendants[ndDpt_,prof_]:=ensembleSommetsPropriete[ndDpt, True&,prof];

ensembleDescendants[ndDpt_]:=ensembleSommetsPropriete[ndDpt, True&,Infinity];

Chemins vers des sommets possédant une propriété

cheminCourant[nd_List]:=Map[cheminCourant,nd]

cheminCourant[nd_]:={}/;SameQ[Head[pereVisiteur[nd]],pereVisiteur]

cheminCourant[nd_]:=Module[{c,r,p},r={nd};p=pereVisiteur[nd];
While[UnsameQ[p,nil],c=p;PrependTo[r,c];p=pereVisiteur[c]];
r]

Chemins par des sommets prescrits

iterCheminSimple[r_,butQ_,longMax_]:=Module[{c,i},
PreIncrement[nbreVisites];
If[butQ[r] ,Throw[r],
If[c=Complement[successeur[Last[r]],r];UnsameQ[c,{}]∧Length[r]≤longMax,
Do[
iterCheminSimple[Append[r,c[[i]]],butQ,longMax]
, {i,1,Length[c]}]]]]

cheminSimple[r_List,butQ_, longMax_]:=Message[cheminSimple::nonEntier]/;Not[IntegerQ[longMax] ∨SameQ[longMax,Infinity]]

cheminSimple[r_List,butQ_,___]:=Message[cheminSimple::nonBooleen]/;TrueQ[Not[MemberQ[{True,False},butQ[r]]]]

cheminSimple[r_List,butQ_, longMax_]:=Module[{ch},nbreVisites=0;ch=Catch[iterCheminSimple[r,butQ,longMax]];niveau=Length[ch]-1;
If[ch===Null,{},ch]]

cheminSimple[r_List,butQ_]:=cheminSimple[r,butQ,Infinity]

cheminSimple[___]:=Message[cheminSimple::arg]

iterCheminCollecte[r_,butQ_, longMax_]:=Module[{c,i},
PreIncrement[nbreVisites];
If[butQ[r] ,AppendTo[collectes,r]; If[niveau<Length[r]-1,niveau=Length[r]-1]];
If[c=Complement[successeur[Last[r]],r];UnsameQ[c,{}]∧ Length[r]-1<longMax,
Do[
iterCheminCollecte[Append[r,c[[i]]],butQ, longMax]
, {i,1,Length[c]}]]]

ensembleCheminsSimples[r_List,butQ_, longMax_]:=Message[ensembleCheminsSimples::nonEntier]/;Not[IntegerQ[longMax] ∨SameQ[longMax,Infinity]]

ensembleCheminsSimples[r_List,butQ_, longMax_]:=(collectes={};nbreVisites=0;niveau=0;iterCheminCollecte[r, butQ, longMax];
collectes)

ensembleCheminsSimples[r_List,butQ_]:=ensembleCheminsSimples[r,butQ,Infinity]

ensembleCheminsSimples[r_List,butQ_,___]:=Message[ensembleCheminsSimples::nonBooleen]/;Not[MemberQ[{True,False},butQ[r]]]

ensembleCheminsSimples[___]:=Message[ensembleCheminsSimples::arg]

cheminBalises[ndDpt_,buts_List]:=Module[{ch,ndCrt,j,prix},
ndCrt=Last[Flatten[{ndDpt}]];
ch={ndCrt};
prix=0;
Do[
ndCrt=sommetPropriete[ndCrt,buts[[j]]];
prix+=nbreVisites;
If[ndCrt==={},Return[ch], ndCrt=First[ndCrt]];
ch=Join[ch, Delete[cheminCourant[ndCrt],1]]
,{j,1,Length[buts]}];
niveau=Length[ch]-1;
nbreVisites=prix;
ch]

descenteForte[ndDpt_, dist_]:=Message[descenteForte::nonNum]/;SameQ[Head[NonNegative[dist[ndDpt]]],NonNegative]∨Not[NonNegative[dist[ndDpt]]]

descenteForte[ndDpt_, dist_]:=Module[{ndCrt,distCrt,ch,suiv,prix},
ndCrt=ndDpt;
distCrt=dist[ndCrt];
ch={ndCrt};
prix=0;
While[distCrt>0,
suiv=sommetPropriete[ndCrt,dist[#]<distCrt&];
prix+=nbreVisites;
If[Length[suiv]==0,Return[{}]];
{ndCrt,distCrt}=minFct[suiv,dist];
ch=Join[ch,Delete[cheminCourant[ndCrt],1]]
];
niveau=Length[ch]-1;
nbreVisites=prix;
ch]

descenteFaible[ndDpt_, dist_]:=Message[descenteFaible::nonNum]/;SameQ[Head[NonNegative[dist[ndDpt]]],NonNegative]∨Not[NonNegative[dist[ndDpt]]]

descenteFaible[ndDpt_, dist_]:=Module[{ndCrt,distCrt,ch,suiv,prix},
ndCrt=ndDpt;
distCrt=dist[ndCrt];
ch={ndCrt};
prix=0;
While[distCrt>0,
suiv=sommetPropriete[ndCrt,dist[#]<distCrt&];
prix+=nbreVisites;
If[Length[suiv]==0,Return[{}]];
{ndCrt,distCrt}=maxFct[suiv,dist];
ch=Join[ch,Delete[cheminCourant[ndCrt],1]]
];
niveau=Length[ch]-1;
nbreVisites=prix;
ch]

Fonctions booléennes (tests)

terminalQ[nd_]:=successeur[nd]==={}

racineQ[nd_]:=predecesseur[nd]==={}

universelQ[nd_]:=StringMatchQ[ToString[nd],"*_*"]

membreQ[x_List]:=TrueQ[MemberQ[x,#]]&

egalQ[x_]:=SameQ[#,x]&

cycleQ[n_Integer][r_List]:=Length[r]-1===n ∧ MemberQ[successeur[Last[r]],First[r]]

longueurQ[n_Integer][r_List]:=Length[r]-1===n

passeParQ[a_List][r_List]:=Complement[a, r]==={}

inclusQ[a_List, b_List]:=Complement[a, b]==={}

sousGrapheQ[g_List][ r_List]:=Complement[r, g]==={}

Autres fonctions

racinesGraphe[]:=ndDptFactuels

profondeur[]:=niveau

profondeur[p_]:=Message[profondeur::nonEntier]/;Not[p===Infinity ∨ (IntegerQ[p] ∧NonNegative[p])]

profondeur[p_]:=($RecursionLimit=8*p;niveauMax=p)

cout[]:=nbreVisites

dernierSommet[fQ_][r_List]:=fQ[Last[r]]

chaqueSommet[fQ_][r_List]:=Apply[And,Map[fQ,r]]

enLignes[x_List]:={}/;Flatten[x]=={}

enLignes[x_List]:=TableForm[x]/;UnsameQ[Head[First[x]],List]

enLignes[x_List]:=Module[{m},
m=Max[Map[Length,x]];
TableForm[
Table[
Join[x[[i]],Table["",{m-Length[x[[i]]]}]],
{i,1,Length[x]}]]]

enColonnes[x___]:=x

enColonnes[x_List]:={}/;Flatten[x]==={}

enColonnes[x_List]:=TableForm[x]/;UnsameQ[Head[First[x]],List]

enColonnes[x_List]:=Module[{m},
m=Max[Map[Length,x]];
TableForm[Transpose[
Table[
Join[x[[i]],Table["",{m-Length[x[[i]]]}]],
{i,1,Length[x]}]]]]

enColonnes[x___]:=x

maxFct[domaine_List, f_]:=Module[{x,y,v,j},
x=domaine[[1]];
y=f[x];
Do[
v=f[domaine[[j]]];
If[v>y,x=domaine[[j]];y=v],
{j,2,Length[domaine]}];
{x,y}]

minFct[domaine_List, f_]:=Module[{x,y,v,j},
x=domaine[[1]];
y=f[x];
Do[
v=f[domaine[[j]]];
If[v<y,x=domaine[[j]];y=v],
{j,2,Length[domaine]}];
{x,y}]

Initialisations

nbreRegles=0;niveau=0;barriereQ:=False&;ndDptFactuels={};collectes={};niveauMax=64;nbreVisites=0;

Fin algorithme

End[];

Protect[debutDeclaration,arc,arcConditionnel,arete,finDeclaration,succ,pred,sommetPropriete,  ensembleSommetsPropriete,ensembleDescendants, cheminSimple,ensembleCheminsSimples,cheminBalises,descenteForte,descenteFaible,racinesGraphe,egalQ,membreQ,cycleQ,longueurQ,inclusQ,passeParQ,sousGrapheQ,dernierSommet, chaqueSommet,profondeur, cout, terminalQ, racineQ, enLignes, enColonnes,maxFct,minFct]

EndPackage[]