unit utheso;
interface
           procedure trait;
implementation
const	nbmot	= 450;	(* nombre de mots du dictionnaire *)
	nbelem	= 2000;	(* nombre d'elements de liste *)
	profond	= 10;	(* profondeur de recherche *)

type	tstring = String[80];
	tmot  =	record	(* entree du dictionnaire *)
		car_mot   : tstring;	 (* valeur du mot *)
		liste_def : integer;	 (* numero de la liste de d‚finition *)
		end;
	telement	= record
		velem	  : integer;	(* valeur de l'‚l‚ment *)
		liste_att : integer;	(* attribut de l'element *)
		suivant   : integer;	(* element suivant de la liste *)
		back	  : integer;	(* ‚lement d‚finissant *)
		end;
	tabback = array[1..profond] of integer;

var	dic	: text;		(* fichier a analyser *)
	dico	: array[1..nbmot] of tmot;	(* dictionnaire *)
	liste	: array[1..nbelem] of telement;	(* table des listes *)
	nmot	: integer;	(* nombre de mot utilises *)
	nelem	: integer;	(* nombre d'elements de liste utilisees *)
	ligne	: tstring;	(* ligne a analyser *)
	position: integer;	(* index dans la ligne *)
	mot	: tstring;	(* mot en analyse *)
	valmot	: integer;	(* numero du mot en analyse *)
	car	: char;		(* caractere courant *)
	ncar	: integer;	(* nombre de caracteres du mot *)
	imbric	: integer;	(* imbrication du mot courrant *)
	tabulation,finligne : char;
	commande: (inconnu , attribut , valeur , quel , lister , tout);
	tabmot	: tabback;	(* question :	mots définissant *)
	tabatt	: tabback;	(*		attributs *)
	tabval	: tabback;	(*		valeurs des attributs *)
	tabaff	: array[1..profond] of boolean;	(* n‚gation de l attribut *)
	et	: boolean;	(* attribut et ou ou *)
	natt	: integer;	(* nombre d'attribut … filtrer *)
	tabv	: array[1..profond] of (vrai , faux , a_calculer); (* val att*)

procedure getcar;
begin		(* extraire le caractŠre suivant de ligne *)
if position > length(ligne)
then	car := finligne
else	begin
	car := char(ligne[position]);	position:=position+1;
	end;
end;
procedure cherchmot;
var	i : integer;
begin		(* rechercher le mot dans le dico, rendre valmot *)
i := 0;		valmot := 0;
while i < nmot do
	begin	
	i := i + 1;
	if dico[i].car_mot = mot
	then	begin
		valmot := i;	i := nmot;
end;	end;	end;
procedure anamot(sep : char);
begin		(* reconstitution d'un mot dans mot *)
		(* sep = '&' si initdico, = ' ' si question *)
		(* recherche du mot dans le dico , valeur dans valmot *)
ncar := 0;	(* si initdico, rajout du mot dans le dico *)
while (car<>'=') and (car <> ',') and (car <> ':')
and (car <> finligne) and (car <> sep) do
	begin
	if car='_'	then	car := ' ';	(* pour les mots composés *)
	if (ncar > 1) or (car <> ' ')
	then	begin
		ncar:=ncar + 1;
		mot[ncar] := ansichar(car);
		end;
	getcar;
	if car=''''	then	car := ' ';
	end;
mot[0] := ansichar(ncar);

cherchmot;

if (valmot = 0) and (sep <> ' ')
then	begin		(* rajout du mot dans le dictionnaire *)
	if nmot = nbmot
	then	writeln(output, 'trop de mots')
	else	begin
		nmot := nmot + 1;
		valmot := nmot;
		with dico[nmot] do
			begin
			car_mot := mot;
			liste_def := 0;
			end;
		end;
	end;
end;
			(************************************************)
			(*	1 - analyse du fichier de donnees	*)
			(************************************************)

procedure getmot;
var	i	: integer;
begin		(* rechercher le mot suivant , rendre valmot *)
if car = finligne
then	begin		(* lecture de la ligne suivante *)
	readln(dic);
	imbric:=0;
	if eof(dic)
	then	car := finligne
	else	begin
		read(dic,ligne);
		position:=1;
		getcar;		(* recherche 1er caractere de la ligne *)
		while car = tabulation do
			begin
			imbric := imbric + 1;
			getcar;
			end;
		end;
	end;
anamot('&');
end;

procedure ajoute_fin_liste(valliste : integer);
var	i : integer;
begin		(* ajouter l'element nelem a la liste valliste *)
i := valliste;
while liste[i].suivant <>  0 do
	i := liste[i].suivant;		(* recherche de la fin de la liste *)
liste[i].suivant := nelem;
end;

procedure ajoute_a_liste(valelement : integer ;
			bak : integer ;
			var lis:integer);
var	valliste	: integer;
begin		(* ajouter un element de valeur valelement a lis *)
nelem:=nelem + 1;
with liste[nelem] do
	begin
	velem:= valelement;	suivant := 0;
	liste_att := 0;		back := bak;
	end;
valliste := lis;
if valliste = 0
then	lis := nelem
else	ajoute_fin_liste(valliste);
end;

procedure definir_mot(bak : integer ; niv : integer ; var lis : integer);
var	listatt	: integer;	vattr	: integer;	cor	: char;
begin
getmot;		(* lecture du 1er attribut ou du mot suivant *)
while imbric = niv + 1 do
	begin
	ajoute_a_liste(valmot , bak , lis);
	listatt := nelem;
	ajoute_a_liste(0 , listatt , dico[valmot].liste_def);
	cor := car;
	if car = ':'
	then	begin
		getcar;
		if car = ':'
		then	begin	(* on traite "::=" comme "=" *)
			getcar;		cor := '=';
			end;
		end;
	if car = '='
	then	begin
		if position <> length(ligne)  then  imbric := imbric + 1;
		getcar;		getmot;
		while imbric = niv + 2 do
			begin
			ajoute_a_liste(valmot,
					listatt, liste[listatt].liste_att);
			vattr := nelem;
			ajoute_a_liste(0, vattr, dico[valmot].liste_def);
			if car = ','	then	getcar;
			definir_mot(vattr , imbric , liste[nelem].liste_att);
			end;
		if cor = ':'
		then	liste[listatt].liste_att :=-liste[listatt].liste_att;
		end
	else	definir_mot(listatt , imbric , liste[nelem].liste_att);
end;	end;

procedure initdico;
begin
tabulation := chr(9);	 finligne := chr(13);
assign(dic,'theso.txt'); reset(dic);
nmot:=0;		 nelem:=0;
read(dic,ligne);
position := 1;
getcar;
getmot;
while not eof(dic) do
	definir_mot(-valmot , 0 , dico[valmot].liste_def );
end;

procedure lire_question;
var	i,j	: integer;
	cor 	: char;
	atrib	: boolean;	(* deuxième partie commencée par dont *)
	atton	: boolean;	(* attente nom d'attribut si true, ou valeur *)

procedure iniatt;
begin		(* analyser la deuxième partie de la question : dont ... *)
if mot = 'ou'
then	begin
	et := false;
	atrib := true;
	end
else	if mot = 'et'
	then	begin
		et := true;
		atrib := true;
		end
	else	begin
		if (mot = 'non') or (mot = 'pas')
		then	tabaff[natt] := false	(* négation d'attribut *)
		else	if mot <> 'n'
			then	if atrib
				then	begin	(* nom d'attribut *)
					natt := natt + 1;
					tabatt[natt] := valmot;
					atrib := false;
					end
				else	begin	(* valeur d'attribut *)
					tabval[natt] := valmot;
					atrib := true;
					end;
		end;
end;

begin		(* code de lire_question *)
writeln('lister, quel, valeur attribut de mot, tout sur mot, attribut de mot'  );
write(output,' ? ');	read(input,ligne);	readln(input);
position:=1;
getcar;
anamot(' ');		(* analyser le 1er mot : la commande *)
commande := inconnu;
if (mot = 'lister') or (mot='liste')
then	commande := lister;
if (mot = 'qui') or (mot='quels')
or (mot='quel') or (mot='quelle') or (mot='quelles')
then	commande := quel;
if (mot = 'décrire') or (mot='définir') or (mot='qu') or (mot='valeur')
then	commande := valeur;
if mot = 'tout'		then	commande := tout;
if ((mot = 'attribut') or (mot = 'attributs'))	then	commande := attribut;
for i := 1 to profond do
	begin
	tabmot[i] := -1;	(* mots définissant *)
	tabatt[i] := -1;	(* noms des attribut *)
	tabval[i] := -1;	(* valeurs des attributs *)
	tabaff[i] := true;	(* affirmation des attributs *)
	end;
natt := 0;
et := true;
atton := false;
atrib := true;
		(* extraire les mots significatifs *)
i:= 0;
while car <> finligne do
	begin
	getcar;
	anamot(' ');
	if (mot<>'le') and (mot<>'la') and (mot<>'les') and (mot<>'des')
	and (mot<>'de') and (mot<>'…') and (mot<>'est') and (mot<>'sont')
	and (mot<>'du') and (mot<>'ce') and (mot<>'que') and (mot<>'qu')
	and (mot<>'un') and (mot<>'une') and (mot<>'sur') and (mot<>'en')
	then	begin
		if valmot = 0
		then	begin	(* on reessaye en enlevant le s du pluriel *)
			j:=length(mot);		cor:=char(mot[j]);
			if (cor='s') or (cor='x')
			then	begin
				mot[0]:=ansichar(j-1);
				cherchmot;
				if valmot = 0	then	mot[0] := ansichar(j);
				end;
			end;
		i := i + 1;
		if (mot = 'dont') or (mot='ayant') or (mot='qui')
		then	atton:=true	(* début des attributs *)
		else	if atton
			then	iniatt
			else	tabmot[i] := valmot;  (* un mot définissant *)
		end;
	end;
end;			(****************************************)
			(*	2 - intérrogation et réponse	*)
procedure repondre;	(****************************************)
var	listedef : integer;
	backmot	 : tabback;
procedure lister_constituant(listedef  : integer ; imbric : integer );
var	i,elem	: integer;
procedure lister_back(var backmot : tabback);
var	i	:integer;
begin		(* écrire la liste des mots définissant *)
if (backmot[2] > 0) and (imbric=0)
and ((commande = tout) or (commande=valeur))
then	begin
	write(output, '* ');
	for i := 2 to profond do
		if backmot[i] > 0
		then	begin
			if i > 2 then	write(output,' de ');
			write(output,dico[backmot[i]].car_mot);
			backmot[i] := 0;
			end;
	writeln(output);
end;	end;

procedure constit_back;
var	i,elem,bak	:integer;
begin		(* établir la liste des mots définissant *)
for i := 1 to profond do
	backmot[i] := 0;
i := 0;
elem := listedef;
while (elem <> 0) and (i < profond) do
	begin
	bak := liste[elem].back;
	i := i + 1;
	if bak <= 0
	then	begin
		backmot[i] := - bak;
		elem := 0;
		end
	else	begin
		backmot[i] := liste[bak].velem;
		elem := bak;
		end;
	end;
end;

function correspond : boolean;
var	i,j,vasy	:integer;
begin			(* déterminer si l'élément répond à la question *)
vasy := 0;		(* correspondance des mots définissant *)
j := 0;
while j < profond do
	begin
	j := j + 1;
	i := 0;
	while i < profond do
		begin
		i := i + 1;
		if (backmot[i] = tabmot[j]) or (tabmot [j] = - 1)
		then	begin
			i := profond;
			vasy := vasy + 1;
			end;
		end;
	end;
if vasy = profond
then	correspond := true
else	correspond := false;
end;

function ok_element(listedef : integer) : boolean;
var	vasy	: boolean;	(* l'élément répond à la question si true *)
	i	: integer;
	att	: integer;
	val	: integer;











procedure anaatr(att : integer);
var	i	:integer;
begin		(* analyse de la liste d'attributs att *)
while att > 0 do
	begin
	if liste[att].velem = 0
	then	anaatr(liste[att].liste_att)
	else	begin
		i := 0;
		while i < natt do
			begin		(* nom de l'attribut *)
			i := i + 1;
			if tabv[i]=a_calculer
			then	begin
				if (tabatt[i] = liste[att].velem)
				then	begin
					val := liste[att].liste_att;
					tabv[i] := faux;
					while val > 0 do
						begin (* valeur de l'attribut*)
						if tabval[i]=liste[val].velem
						then	begin
							tabv[i] := vrai;
							val := 0;
							end
						else  val :=liste[val].suivant;
						end;
					end;
				end;
			end;
		end;
	att := liste[att].suivant;
	end;
end;

procedure remonte;
var	bak : integer;
begin		(* pour analyser les attributs des mots englobants *)
if liste[listedef].velem = 0
then	listedef := liste[listedef].back;
bak := liste[listedef].back;
listedef := 0;
if bak > 0
then	begin
	if liste[bak].liste_att < 0
	then	begin	(* c'est un mot classificateur *)
		bak := liste[bak].back;
		if bak > 0
		then	listedef := bak
		else	begin
			listedef:=nelem+1;
			att := dico[-bak].liste_def;
			liste[listedef].back:=0;
			liste[listedef].liste_att:=att;
			liste[listedef].velem:=0;
			end;
		end;
	end;
end;



begin		(* code de ok_element : analyse des attributs *)
if tabatt [1] = -1
then	vasy := true
else	begin
	for i := 1 to natt do tabv[i] := a_calculer;
	while listedef > 0 do
		begin
		att := liste[listedef].liste_att;
		if att < 0
		then	begin
			vasy := false;	(* c'est un classificateur := *)
			listedef := 0;
			end
		else	begin		(* c'est un attribut = *)
			if att = 0
			then	begin
				att:=liste[listedef].velem;
				if att > 0
				then	att:=dico[att].liste_def;
				end;
			anaatr(att);
			vasy := false;
			for i:=1 to natt do
				if tabv[i] = a_calculer
				then	vasy := true;
			if vasy
			then	remonte	(* étudier attributs des englobants *)
			else	listedef := 0;
			end;
		end;
	for i := 1 to natt do
		if not tabaff[i]	(* négation des attributs *)
		then	if tabv[i] = vrai
			then	tabv[i] := faux
			else	tabv[i] := vrai;
	if et
	then	begin
		vasy := true;
		for i:=1 to natt do
			if tabv[i]<>vrai	then	vasy := false;
		end
	else	begin
		vasy := false;
		for i:=1 to natt do
			if tabv[i]=vrai		then	vasy := true;
		end;
	end;
if vasy	then	ok_element := true	else	ok_element := false;
end;

procedure lister_element(listedef : integer ; imbric : integer ;
			 var backmot :tabback);
var	i,att,elem,ele	: integer;
begin
if (commande <> lister) and ok_element(listedef)
then	begin
	lister_back(backmot);
	for i:=1 to imbric do write(output,'    ');
	imbric := imbric + 1;
	elem := liste[listedef].velem;
	if commande = attribut
	then	att := 0
	else	att := liste[listedef].liste_att;
	write(output,dico[elem].car_mot);
	if att > 0 then write(output,' = ');
	if att < 0 then write(output,' := ');
	att := abs(att);
	while att > 0 do
		begin
		elem := liste[att].velem;
		write(output, dico[elem].car_mot);
		att := liste[att].suivant;
		if att <> 0	then write(output,', ');
		end;
	writeln(output);
	end;

att:= liste[listedef].liste_att;
if (att < 0) and ( (commande =tout) or (commande=lister) or (commande=quel))
then	begin	(* liste classificatoire en := *)
	imbric := imbric + 1;
	elem := -att;
	while elem > 0 do
		begin
		ele := liste[elem].velem;
		if ele > 0
		then	att := dico[ele].liste_def;
		if ok_element(elem)
		then	begin
			for i := 1 to imbric do	write(output,'    ');
			writeln(output,dico[ele].car_mot);
			end;
		while att > 0 do
			begin
			lister_constituant(att , imbric+1 );
			att := liste[att].suivant;
			end;
		elem := liste[elem].suivant;
		end;
	end;
end;
begin		(* code de lister_constituant *)
constit_back;
elem := liste[listedef].velem;
if correspond or (imbric <> 0)
then	if elem = 0
	then	begin
		elem := liste[listedef].liste_att;
		if elem = 0
		then	begin
			elem := liste[listedef].back;
			if elem > 0
			then	elem := liste[elem].liste_att
			else	elem := 0;
			end;
		listedef := abs(elem);
		if listedef = 0
		then	lister_back(backmot)
		else	while listedef <> 0 do
				begin
				lister_element(listedef , imbric ,backmot);
				listedef := liste[listedef].suivant;
				end;
		end
	else	lister_element(listedef , imbric ,backmot);
end;
		(* code de repondre *)
begin		(* repondre à la question : commande mot1 mot2 *)
if tabmot[1] > 0
then	listedef := dico[tabmot[1]].liste_def
else	listedef := 0;
if listedef = 0 	then	tabmot[1] := 0;
if tabmot[1] <= 0
then	writeln(output,'je ne sais rien sur ca')
else	while listedef <> 0 do
		begin
		lister_constituant(listedef , 0);
		listedef := liste[listedef].suivant;
		end;
end;

procedure help;
var f : text;
  ligne:string;
  car:char;
begin
assign(f,'theso.hlp');
reset(f);
while not eof(f) do
  begin
  read(f,ligne); readln(f);
  writeln(ligne);
  if (ligne='*')
  then    begin
          writeln('frapper return');
          read(car);readln;
          end;
  end;

end;

procedure trait;
begin
initdico;		(* analyser le fichier de données *)

while ((mot <> 'fin') and (mot <> 'quit')) do
	begin
	lire_question;	(* lire la question *)
	if (ligne='help') or (ligne='?')	then	help;

	if commande <> inconnu
	then	repondre;	(* donner les informations *)
	end;
end;
end.
