unit ufait;

interface
uses umain;
  procedure convrtit(fai :integer);
  procedure tassert(tete_queue : integer;coi : integer;cocoi:integer);
  procedure treplace(ty:integer;coi : integer);
  procedure tretract(retrana:integer;co:integer; coi:integer);
  procedure tfunctor;
  procedure tfunction;
  procedure tname;
  procedure tstrulist;
  procedure hsh_coded;


implementation
uses usp,uunif,userv;

		(********************************)
		(*	assert			*)
		(*	retract			*)
		(*	anafact			*)
		(*	function, name ,:=:	*)
		(*	functor			*)
		(*	hsh_coded		*)
		(*  mfait.pas	 - prolog	*)
		(********************************)

procedure convrtit(fai :integer);
var	xfa,fa,chai : integer;
begin
if fai<> 0
then	begin
	fa := getval(fai);
	xfa:=noeud^[fa].code;
lire_symbole(noeud^[fa].code);
if symbole_lu = 'X' then convertir_mot('_x',0,xfa);
if symbole_lu = 'Y' then convertir_mot('_y',0,xfa);
if symbole_lu = 'Z' then convertir_mot('_z',0,xfa);
	cindex := cindex+1;
	tconver[cindex] := xfa;
	if tconver[cindex] = p_nombre
	then	begin
		nb.rea := noeud^[fa].value;

		tconver[cindex+1] := nb.int1;
		tconver[cindex+2] := nb.int2;
		tconver[cindex+3] := nb.int3;
		cindex := cindex + 3;

		end;
	chai := noeud^[fa].fils;
	while chai <> 0 do
		begin
		fa := noeud^[chai].frere;
		convrtit(chai);
		chai := fa;
		end;
	end;
end;

procedure tassert(tete_queue : integer;coi : integer;cocoi:integer);
var	fai	: integer;
	ind	: integer;
begin
if coi = 1
then	begin
	if cocoi = 0
	then	ind := - last_index
	else	ind := - trunc(evaluation(noeud^[fils2].frere));
	end
else	ind := 0;
cindex := 0;
convrtit(fait1);
tconver[cindex+1] := 0;
conclusion := tconver;
l_cl := cindex + 1;
fait2 := getval(fait2);
if (noeud^[fait2].code <> p_point) and  (noeud^[fait2].code <> p_nil)
then	backtrack := true
else	begin
	cindex := 0;
	while fait2 <> 0 do
		begin
		lire_element(fait2,fai);
		convrtit(fai);
		end;
	if cindex = 0
	then	conditions[1] := 0	(* un fait *)
	else	begin			(* une rŠgle *)
		tconver[cindex+1] := 0;
		conditions := tconver;
		l_cd := cindex + 1;
		end;
	enregistrer(tete_queue,ind);
	end;
end;

procedure treplace(ty:integer;coi : integer);
var	goon	: boolean;
	reg,regl: integer;
	fai	: integer;
	numhsh	: integer;
	code_fait	: integer;
	ind	: integer;
	compok	: boolean;
	olde	: integer;
	oldenv	: integer;
	c1,c2,t2: integer;
begin
if coi = 1
then	begin
	if ty = 2
	then	ind := - last_index
	else	ind := - trunc(evaluation(noeud^[fils2].frere));
	end;
goon := true;
numhsh := table_symbole^[fils1_code].phsh_coded;
if numhsh > 0
then	calcule_coded(fils1 , reg , numhsh , code_fait);
if numhsh <= 0
then	reg := table_symbole^[fils1_code].premier;

while goon do
	begin
	if reg = 0
	then	begin
		goon := false;
		backtrack := true;
		end
	else	begin
		oldenv := nenv;
		if coi = 0
		then	ind := reg;
		if ind = reg
		then	begin
			empile_env;
			pcond := addr(table_fait^[reg]^.fait[1]);

			c1 := pcond^ [1];
			c2 := pcond^ [2];
			if c2 =  p_point
			then	c2 := pcond^[3];
			if coi = 0
			then	begin
				cindex := 1;
				ralo := table_fait^[reg]^.ral_cond;
				olde:=nniveau;
				decomp(fai,olde);
				if unifier(fils1,fai)
				then	compok := true
				else	compok := false;
				end
			else	compok := true;
			if compok
			then	begin
				goon := false;
				if coi = 0
				then	begin
					fait1 := noeud^[fait2].frere;
					fait2 := noeud^[fait1].frere;
					end;
				cindex := 0;
				convrtit(fait1);
				tconver[cindex+1] := 0;
				if tconver[1] <> c1
				then	begin
					backtrack := true;
					goon := false;
					end
				else	begin
				if numhsh > 0
				then	begin
					t2 := tconver[2];
					if t2 = p_point
					then	t2 := tconver[3];
					if t2 <> c2
					then
				table_symbole^[fils1_code].phsh_coded := -1;
					end;
				l_cl := cindex + 1;
				conclusion := tconver;
				fait2 := getval(fait2);
				if (noeud^[fait2].code <> p_point)
				and  (noeud^[fait2].code <> p_nil)
				then	backtrack := true
				else	begin
					liber_fait(table_fait^[reg]^.regle);
					liber_fait(table_fait^[reg]^.ral_cond);
					table_fait^[reg]^.ral_cond:=0;
					cindex := 0;
					while fait2 <> 0 do
						begin
						lire_element(fait2,fai);
						convrtit(fai);
						end;
					if cindex = 0
					then	begin
						conditions[1] := 0;	(* un fait *)
						l_cd := 1;
						end
					else	begin			(* une rŠgle *)
						tconver[cindex+1] := 0;
						conditions := tconver;
						l_cd := cindex + 1;
						end;
					met(conclusion, reg , l_cl);
					if conditions[1] = 0
					then	regl := 0
					else	begin
						if (conditions[1] = p_coupe0)
						and (conditions[2] = 0)
						then	regl := -1
						else	begin
							prendre_fait(regl);
						met(conditions, regl , l_cd);
							end;
						end;
					table_fait^[reg]^.regle := regl;
					end;
				    end;
				end;
			end;
		if goon
		then	begin
			if numhsh <= 0
			then	reg := table_fait^[reg]^.suivant
			else	begin
				reg := table_fait^[reg]^.coded_next;
				if reg < 0
			then	reg := table_fait^[-reg]^.fait[code_fait+1];
				end;
			nenv := oldenv;
			end;
		end;
	end;
end;

procedure tretract(retrana:integer;co:integer; coi:integer);
var	goon	: boolean;
	reg,prec: integer;
	fai,rg	: integer;
	rgl	: integer;
	ind	: integer;
	olde	: integer;
	oldenv	: integer;
begin
prec := 0;
goon := true;
reg := table_symbole^[fils1_code].premier;
if table_symbole^[fils1_code].phsh_coded > 0
then	table_symbole^[fils1_code].phsh_coded := -1;
if coi = 1
then	begin
	ind := - trunc(evaluation (noeud^[fils2].frere));
	end;

while goon do
	begin
	if reg = 0
	then	begin
		goon := false;
		backtrack := true;
		end
	else	begin
		oldenv := nenv;
		if coi = 0
		then	ind := reg;
		if ind = reg
		then	begin
			coi := 0;
			empile_env;
			cindex := 1;
			pcond := addr(table_fait^[reg]^.fait[1]);
			ralo := table_fait^[reg]^.ral_cond;
			olde := nniveau;
			decomp(fai,olde);
			if unifier(fils1,fai)
			then	begin
				crevide(rg);
				cindex := 1;
				rgl := table_fait^[reg]^.regle;
				if rgl <> 0
				then	begin
					pcond :=addr(table_fait^[rgl]^.fait[1]);
					ralo := table_fait^[rgl]^.ral_cond;
					while table_fait^[rgl]^.fait[cindex]
							<> 0 do
						begin
						decomp(fai,olde);
						ajoute_element(fai,rg);
						end;
					end;
				if unifier(fils2,rg)
				then	begin
					goon := false;
					snum := co;   (* pour retour arriŠre *)
					if retrana=0
					then	begin
					with table_symbole^[noeud^[fils1].code] do
						begin
						if reg = dernier
						then	dernier := prec;
						if prec = 0
						then	premier :=
							table_fait^[reg]^.suivant
						else	table_fait^[prec]^.suivant :=
							 table_fait^[reg]^.suivant;
						end;
						liber_fait(reg);
						end;
					end;
				end;
			end;
		if goon
		then	begin
			prec := reg;
			reg := table_fait^[reg]^.suivant;
			nenv := oldenv;
			end;
		end;
	end;
end;

procedure tfunctor;
var	c2,i,k,j	: integer;
	prec,el,nb_arg	: integer;
	sym		: ttstring;
begin
nb_arg := trunc(evaluation(noeud^[fait2].frere));
c2:=noeud^[fils2].code;
if (noeud^[fils2].niveau=-1) and (nb_arg>=0) and (nb_arg<10)
then	begin
	lire_symbole(c2);
	convertir_mot(symbole_lu,nb_arg,i);
	prend_noeud(j);
	noeud^[j].code:=i;
	for k := 1 to nb_arg do
		begin
		prend_noeud(el);
		sym:='__ ';
		sym[3] := ansichar(chr(k + 48));
		convertir_mot(sym,0,i);
		noeud^[el].code:=i;
		nniveau:=nniveau+1;
		noeud^[el].niveau:=nniveau;
		table_env^[nenv+nniveau] := 0;
		(* envcour[nniveau-nenv]:=0; *)
		if k = 1
		then	noeud^[j].fils := el
		else	noeud^[prec].frere := el;
		prec := el;
		end;
	if unifier(fils1,j) then;
	end
else	backtrack := true;
end;

procedure tfunction;
var	c1,c2,i,j:integer;
begin
c1:=noeud^[fils1].code;
c2:=noeud^[fils2].code;
if noeud^[fils2].niveau=-1
then	begin
	lire_symbole(c2);
	convertir_mot(symbole_lu,table_symbole^[c1].nbr_arg,i);
	prend_noeud(j);
	noeud^[j].code:=i;
	noeud^[j].fils := noeud^[fils1].fils;
	if unifier(fils1,j) then;
	end
else	backtrack := true;
end;

procedure tname;	(* name (variable,variable ou liste) *)
var	chaine	: ttstring;
	i,j,k,v	: integer;
	point,el: integer;
	sy_lu	: ttstring;
begin
backtrack:=false;
if noeud^[fils2].code <> p_point
then	begin
	crevide(j);
	lire_symbole(noeud^[fils1].code);
	sy_lu:=symbole_lu;
	for k := 1 to length(sy_lu) do
		begin
		car := char(sy_lu[k]);
		convertir_mot(car,0,v);
		prend_noeud(i);
		noeud^[i].code := v;
		ajoute_element(i,j);
		end;
	if not unifier(j,fils2)
	then	backtrack := true;
	end
else	begin
	point:=fils2;
	chaine:='';
	while point <> 0 do
		begin
		lire_element(point,el);
		if el <> 0
		then	begin
			lire_symbole(noeud^[el].code);
			chaine:=chaine + symbole_lu;
			end;
		end;
	convertir_mot(chaine,
			table_symbole^[noeud^[fils1].code].nbr_arg,i);
	prend_noeud(j);
	noeud^[j].code := i;
	if not unifier(fils1,j)
	then	backtrack := true;
	end;
end;

procedure tstrulist;
var	el,sor	: integer;
	pre,i,j,n	: integer;
begin
if noeud^[fils2].code = p_point
then	begin
	prend_noeud(pre);
	i := 0;
	n := 0;
	while fils2 <> 0 do
		begin
		lire_element(fils2,el);
		if el <> 0
		then	begin
			case i of
				0	:begin
					el := getval(el);
					noeud^[pre].code := noeud^[el].code;
					i := -1;
					end;
				-1	:begin
					prend_noeud(j);
					noeud^[j] := noeud^[el];
					noeud^[j].frere := 0;
					noeud^[pre].fils := j;
					n := n + 1;
					i := j;
					end;
				else	begin
					prend_noeud(j);
					noeud^[j] := noeud^[el];
					noeud^[j].frere := 0;
					noeud^[i].frere := j;
					i := j;
					n := n + 1;
					end;
				end;
			end;
		end;
	lire_symbole(noeud^[pre].code);
	convertir_mot(symbole_lu,n,j);
	noeud^[pre].code := j;
	if unifier(fils1,pre) then;
	end
else	begin
	crevide(sor);
	prend_noeud(i);
	lire_symbole(noeud^[fils1].code);
	convertir_mot(symbole_lu,0,j);
	noeud^[i].code := j;
	ajoute_element(i,sor);
	fils1 := noeud^[fils1].fils;
	while fils1 <> 0 do
		begin
		ajoute_element(fils1,sor);
		fils1 := noeud^[fils1].frere;
		end;
	if unifier(fils2,sor) then;
	end;
end;

procedure hsh_coded;
var	i	: integer;
begin
if nhsh_coded >= max_hsh_coded
then	begin
	eros;
	writeln(output,'trop de hsh_coded');
	end
else	begin
	if fils1_code <= npredef
	then	begin
		eros;
		writeln(output,'Une predefinie ne peut pas etre hsh_coded');
		end
	else	begin
		if table_symbole^[fils1_code].premier <> 0
		then	begin
				(*devrait etre vide pour hsh_coded*)
			end
	else	begin
		if fils2 <> 0
		then	begin
			eros;
			writeln(output,'La relation n''a pas d''arguments');
			end
		else	begin
			nhsh_coded := nhsh_coded + 1;
			new(table_coded[nhsh_coded]);
			for i := 0 to max_coded do
				begin
				table_coded[nhsh_coded]^.tete_coded[i] := 0;
				table_coded[nhsh_coded]^.queue_coded[i] := 0;
				end;
			table_symbole^[fils1_code].phsh_coded := nhsh_coded;
			end;
		end;
		end;
	end;
end;

end.
