unit userv;

interface
uses umain,usp;
  procedure met(var conclusion : cond ; index : integer ; lg : integer);
  procedure enregistrer(tete_queue : integer;ind : integer);
  procedure ecrire(objet:integer);
  procedure ecr(objet1:integer);
  function compobj(objet1,objet2:integer) : boolean;
  function comptop(objet1:integer) : boolean;
  procedure ecri(fait : integer ; var des1 : tdes ; ty : integer);
  procedure decomp(var condit	: integer ;
		top		: integer);
  procedure calcule_coded(regle:integer;
	  var numero:integer; var numhsh:integer; var code_fait : integer);
  procedure ajoute_arbre(regle : integer);


implementation

		(************************************************)
		(*		enregistrer			*)
		(*		ecrire				*)
		(*		decomp				*)
		(*		ajoute_arbre de resolution	*)
		(*	mserv.pas	-	prolog		*)
		(************************************************)
		(************************************************)
		(*	enregistrer une regle ou un fait	*)
		(************************************************)

procedure met(var conclusion : cond ; index : integer ; lg : integer);
var	pcond	: ptcond;
	i,j	: integer;
begin
i := 1;
while i <= lg do
	begin
	if i <> 1
	then	begin
		prendre_fait(j);
		table_fait^[index]^.ral_cond := j;
		index := j;
		end
	else	table_fait^[index]^.ral_cond := 0;

	pcond := addr(conclusion[i]);
	table_fait^[index]^.fait := pcond^;

	i := i + m_cond;
	end;
end;



procedure enregistrer(tete_queue : integer;ind : integer);
var	code_fait		: integer;
	index_fait		: integer;
	ii,jj			: integer;
	goon			: boolean;

procedure enreg_hsh(numhsh : integer);
var	k,j,i,mincoded,maxcoded	: integer;
begin
with table_coded[numhsh]^ do
	begin
	j := 3;
	code_fait := conclusion[2];
	if code_fait = p_point
	then	begin
		code_fait := conclusion[3];
		j := 4;
		end;
	if code_fait = p_nombre
	then	begin

		nb.int1 := conclusion[j];
		nb.int2 := conclusion[j+1];
		nb.int3 := conclusion[j+2];

		if (nb.rea > 32767) or (nb.rea < -32767)
		then	code_fait := 0
		else	code_fait := abs(trunc(nb.rea)) mod mx_coded;
		mincoded := code_fait;
		maxcoded := code_fait;
		end
	else	begin
		lire_symbole(code_fait);
		if symbole_lu[1] <> '_'
		then	begin
			code_fait := code_fait mod mx_coded;
			mincoded := code_fait;
			maxcoded := code_fait;
			end
		else	begin
			mincoded := 0;
			maxcoded := max_coded;
			prendre_fait(i);
			table_fait^[index_fait]^.coded_next := -i;
			for k := 1 to mx_coded do
				table_fait^[i]^.fait[k] := 0;
			end;
		end;
	for i := mincoded to maxcoded do
		begin
		if tete_queue = 0
		then	begin
			if tete_coded[i] = 0
			then	tete_coded[i] := index_fait;
			if queue_coded[i] <> 0
			then	begin
				j:=table_fait^[queue_coded[i]]^.coded_next;
				if j = 0
				then	table_fait^[queue_coded[i]]^.coded_next
						:= index_fait
				else	begin
					table_fait^[-j]^.fait[i+1] := index_fait;
					end;
				end;
			queue_coded[i] := index_fait;
			end
		else	begin
			j := table_fait^[index_fait]^.coded_next;
			if j = 0
			then	table_fait^[index_fait]^.coded_next
					:= tete_coded[i]
			else	table_fait^[-j]^.fait[i+1] := tete_coded[i];
			if tete_coded[i] = 0
			then	queue_coded[i] := index_fait;
			tete_coded[i] := index_fait;
			end;
		end;
	end;
end;

begin		(* code de enregistrer *)
if nfait = max_fait-1
then	begin
	ok := false;
	writeln(output,'trop de faits et regles');
	end
else	begin
	code_fait := conclusion[1];
	lire_symbole(code_fait);
	if code_fait <= npredef
	then	writeln(output,'le predicat ',symbole_lu,
			' ne peut etre redefini')
	else	begin
		if not compile
		then	begin
			prendre_fait(index_fait);
			last_index := - index_fait;
			with table_symbole^[code_fait] do
				begin
				if tete_queue > 1
				then	begin
					if ind <= 0
					then	tete_queue := 1
					else	begin
						if table_fait^[premier]^.fait[1]
							<> conclusion[1]
						then	tete_queue := 4;
						end;
					end;
				case tete_queue of
				   0:	begin
					if premier = 0
					then	premier := index_fait;
					if dernier <> 0
					then	table_fait^[dernier]^.suivant
							:= index_fait;
					dernier := index_fait;
					end;
				   1:	begin
					table_fait^[index_fait]^.suivant
						:= premier;
					if premier = 0
					then	dernier := index_fait;
					premier := index_fait;
					end;
				   2:	begin	(* before *)
					goon := true;
					jj := premier;
					ii := 0;
					while goon and (jj>0) do
						begin
						if jj = ind
						then	goon := false
						else	begin
							ii := jj;
							jj := table_fait^[jj]^.suivant;
							end;
						end;
					if not goon
					then	begin
					table_fait^[index_fait]^.suivant := ind;
					if ii>0
					then	table_fait^[ii]^.suivant := index_fait;
					if ind = premier
					then	premier := index_fait;
						end;
					end;
				   3:	begin	(* after *)
					table_fait^[index_fait]^.suivant :=
						table_fait^[ind]^.suivant;
					table_fait^[ind]^.suivant := index_fait;
					if dernier = ind
					then	dernier := index_fait;
					end;

				else
				   end;
				if phsh_coded > 0
				then	enreg_hsh(phsh_coded);
				end;
			with table_fait^[index_fait]^ do
				begin
				met(conclusion,index_fait,l_cl);
				regle := 0;
				if conditions[1] <> 0
				then	begin
					if (conditions[1] = p_coupe0)
					and (conditions[2] = 0)
					then	regle := -1
					else	begin
					prendre_fait(index_fait);
					regle := index_fait;
					met(conditions,index_fait,l_cd);
						end;
					end;
				end;
			end;
		end;
	end;
end;

		(****************************************)
		(*	impression d'un objet prolog	*)
		(****************************************)


procedure ecrire(objet:integer);
var	suite		: integer;
	rea		: real;
	truncrea	: integer;
	debut,biz	: boolean;
	suit		: integer;
	inte		: integer;
	parent		: boolean;
begin
if objet <> 0
then	begin
	objet := getval(objet);
	with noeud^[objet] do
		begin
		if code = p_moinsu
		then	begin
			inte := getval(fils);
			inte := noeud^[inte].code;
			if (inte=p_plus) or (inte=p_moins) or (inte=p_moinsu)
			then	begin
				tcar('-');
				tcar('(');
				ecrire(fils);
				tcar(')');
				end
			else	begin
				tcar('-');
				ecrire(fils);
				end;
			end
		else if ((code>=p_plus) and (code<=p_egagrand))
		then	begin
			if code >= p_egalu
			then	begin
				ecrire(fils);
				lire_symbole(code);
				putk(symbole_lu);
				ecrire(noeud^[fils].frere);
				end
			else	begin
				inte := getval(fils);
				inte := noeud^[inte].code;
				parent := false;
				if (inte >= p_plus) and (inte < p_egalu)
				then	begin
					if code > p_moins
					then	begin
						if code = p_puiss
						then	parent := true
						else	begin
							if inte <= p_moins
							then	parent := true;
							end;
						end;
					end;
				if parent
				then	tcar('(');
				ecrire(fils);
				if parent
				then	tcar(')');
				lire_symbole(code);
				putk(symbole_lu);
				inte := getval(noeud^[fils].frere);
				inte := noeud^[inte].code;
				parent := false;
				if (inte>=p_plus) and (inte<p_egalu)
				then	begin
					case code of
						p_moins	:begin
							if inte <= p_moins
							then	parent := true;
							end;
						p_mul,p_divise	:begin
							if inte <= p_moins
							then	parent := true;
							end;
						p_puiss	:parent := true;
						else
						end;
					end;
				if parent
				then	tcar('(');
				ecrire(noeud^[fils].frere);
				if parent
				then	tcar(')');
				end;
			end
		else	begin
			if code = p_nombre
			then	begin
				rea := noeud^[objet].value;
				if (rea>=minint) and (rea<=maxint)
				then	begin
					truncrea := trunc(rea);
					if truncrea = rea
					then	putint(truncrea)
					else	putrea(rea);
					end
				else	putrea(rea);
				end
			else	if (not indput)
				or ((code <> p_point) and (code <> p_nil))
				then	begin
					lire_symbole(code);
					putktxt(symbole_lu);
					end;
			suite := fils;
			if suite <> 0
			then	begin
				if code <> p_point
				then	tcar('(');
				biz := false;
				debut := true;
				while suite <> 0 do
					begin
					if not debut
					then	begin
						if indword
						then	tcar(' ')
						else	begin
							if (code <> p_point)
							or (not indput)
							then	tcar(',');
							end;
						end;
					debut := false;
					if biz
					then	tcar('!');
					biz := false;
					if code = p_point
					then	begin
						ecrire(suite);
						suite := noeud^[suite].frere;
						if suite <> 0
						then	begin
						suit := getval(suite);
						if (noeud^[suit].code <>
								p_point)
						and (noeud^[suit].code <>
								p_nil)
						then	biz := true
						else suite:=noeud^[suit].fils;
							end;
						end
					else	begin
						ecrire(suite);
						suite := noeud^[suite].frere;
						end;
					end;
				if code = p_point
				then	begin
					if not indput
					then	tcar(']')
					end
				else	tcar(')');
				end;
			end;
		end;
	end;
end;

procedure ecr(objet1:integer);
	var	suiv,fils	:integer;
begin
objet1:=getval(objet1);
with noeud^[objet1] do
	begin
	lire_symbole(code);
	write(symbole_lu);
	fils:=noeud^[objet1].fils;
	if fils <> 0
	then	begin
		write('(');
		ecr(fils);
		suiv:=noeud^[fils].frere;
		while suiv <> 0 do
			begin
			write(',');
			ecr(suiv);
			suiv:=noeud^[suiv].frere;
			end;
		write(')');
		end;
	end;
end;

function compobj(objet1,objet2:integer) : boolean;
var	suiv1,suiv2	: integer;
	fils1,fils2	: integer;
	comp		: boolean;
	indarbre	: integer;
begin
	comp := true;
	objet1:=getval(objet1);
	objet2:=getval(objet2);
	(* write('compobj ',objet1,' ',objet2);ecrire(objet1);write(' à ');ecrire(objet2);writeln;
	write('ecr ');ecr(objet1);write(' ');ecr(objet2);writeln; *)
	with noeud^[objet1] do
		begin
		suiv1:=0;
		suiv2:=0;
		if code <> noeud^[objet2].code
		then	begin
			comp:=false;
			end
		else	begin
			fils1:=noeud^[objet1].fils;
			fils2:=noeud^[objet2].fils;
			if fils1 <> 0
			then	begin
				if not compobj(fils1,fils2)
				then	begin
					comp:=false;
					end
				else	begin
					suiv1:=noeud^[fils1].frere;
					suiv2:=noeud^[fils2].frere;
					end;
				end;
			end;
		if (suiv1 > 0) and (suiv2 > 0)
		then	begin
			while suiv1 >0 do
				begin
				(*suiv1:=getval(suiv1);
				suiv2:=getval(suiv2);*)
				if compobj(suiv1,suiv2)
				then	begin
					suiv1:=noeud^[suiv1].frere;
					suiv2:=noeud^[suiv2].frere;
					end
				else	begin
					suiv1:=0;
					comp:=false;
					end;
				end;
			end;
		end;
compobj:= comp;
end;

function comptop(objet1:integer) : boolean;
var
	indarbre,ii,objet2	: integer;
	comp	: boolean;
begin
comp:=false;
indarbre:=0;
if objet1 > 0
then	begin
	indarbre:=noeud^[objet1].depend;
	if noeud^[objet1].code <= npredef
	then	indarbre := 0;
	end;
if indarbre > 0
then	begin
	if nloop=0
	then	indarbre:=0
	else	begin
		for ii:=1 to nloop do
			if (table_loop[ii] = noeud^[objet1].code)
			or (table_loop[ii] = p_all)
			then	comp:=true;
		if not comp
		then	indarbre:=0;
		end;
	end;
if indarbre> 0
then	begin

	objet2:=table_arbre^[indarbre].demo;
	if trace
	then	begin
		write('comtop : ');ecrire(objet1);writeln(': ',indarbre);
		for ii:=1 to narbre do
			begin
			write('pile = ');ecrire(table_arbre^[narbre-ii+1].demo);
			writeln(' ');
			end;
		write('comtop premier : ');ecrire(objet2);writeln(': ',indarbre);
		end;
	comp:=compobj(objet1,objet2);
	if not comp
	then	begin
		indarbre:=noeud^[objet2].depend;
		if indarbre>0
		then	begin
			objet2:=table_arbre^[indarbre].demo;
			if trace
			then	begin
				write('compobj second : ');ecrire(objet2);writeln;
				end;
			comp:=compobj(objet1,objet2);
			if not comp
			then	begin
				indarbre:=noeud^[objet2].depend;
				if indarbre>0
				then	begin
					objet2:=table_arbre^[indarbre].demo;
					if trace
					then	begin
						write('compobj trois : ');ecrire(objet2);writeln;
						end;
					comp:=compobj(objet1,objet2);
					if not comp
					then	begin
						indarbre:=noeud^[objet2].depend;
						if indarbre>0
						then	begin
							objet2:=table_arbre^[indarbre].demo;
							if trace
							then	begin
								write('compobj quatre : ');ecrire(objet1);write(' ');ecrire(objet2);writeln(' quatre');
								end;
							comp:=compobj(objet1,objet2);
							end;
						end;
					end;
				end;
			end;
		end;
	if comp
	then	begin
		if trace or (table_loop[2] = p_stop)
		then	begin
			write('Stop ',indarbre,' ');
			ecrire(objet1);writeln;
			end;
		end;
	end;
comptop:=comp;
end;

procedure ecri(fait : integer ; var des1 : tdes ; ty : integer);
var	i	: integer;
begin
with des1 do
	begin
	if (ty = 0) or (ty = 1) or (ty=3) or (ty=4)
	then	begin
		if l <> 0
		then	begin
			posit(l,c);
			if rz
			then	begin
				if ty=4
				then	begin
					write(output,'                         ');
					posit(l,c);
					end
				else	clreol;
				end;
			end;
		if (ty = 0) and (numer <> -1)
		then	begin
			highvideo;
			write(output,numer);
			lowvideo;
			remet_couleur;
			write(output,'  ');
			end;
		if v = p_videoinv
		then	highvideo;
		if v = p_videonor
		then	lowvideo;
       (*		if tc <> -1
		then	textcolor(tc);
		if bc <> -1
		then	textbackground(bc);    *)
		if ty=3
		then	begin
			clreol;
			write(output,' ');
			end;
		if ty=4
		then	begin
			write(output,'                         ');
			posit(l,c);
			write(output,' ');
			end;
		end;
	if (ty = 0) or (ty=3) or (ty=4)
	then	begin
		if fait > 0
		then	begin
			indput := true;
			indword := true;
			ecrire(fait);
			indput := false;
			indword := false;
			end
		else	begin
			case -fait of
				0	: begin
					end;
				1	: write(output,'rubrique a modifier ');
				2	: write(output,'votre choix ');
				end;
			end;
		end;
	if (ty = 0) or (ty=2)
	then	begin
		if v = p_videoinv
		then	lowvideo;
		if v = p_videonor
		then	highvideo;
       (*		if ((v <> 0) or (tc <> -1))
		and ( color_texte <> -1)
		then	textcolor(color_texte);
		if ((v <> 0) or (bc <> -1))
		and ( color_fond <> -1)
		then	textbackground(color_fond);   *)
		end;
	end;
end;

(*.m mainmodule *)

		(************************************************)
		(*	decompression d'un fait ou regle	*)
		(************************************************)
procedure decomp(var condit	: integer ;
		top		: integer);
var	nb_arg,i,niv,nn	: integer;
	nouveau,ancien	: integer;
	codemul		: boolean;
begin
prend_noeud(nn);
condit := nn;
with noeud^[nn] do
	begin
	fils := 0;
	frere := 0;
	depend := 0;
	code := pcond^[cindex];
	if code = p_coupe0
	then	value := narbre;
	if code < -2
	then	begin
		code := - code;
		codemul := true;
		end
	else	codemul := false;
	if (cindex = m_cond) and (ralo <> 0)
	then	begin
		cindex := 1;

		pcond := addr(table_fait^[ralo]^.fait[1]);

		ralo := table_fait^[ralo]^.ral_cond;
		end
	else	cindex := cindex + 1;
	if code = p_nombre
	then	begin

		nb.int1 := pcond^[cindex];
	if (cindex = m_cond) and (ralo <> 0)
	then	begin
		cindex := 1;
		pcond := addr(table_fait^[ralo]^.fait[1]);

		ralo := table_fait^[ralo]^.ral_cond;
		end
	else	cindex := cindex + 1;
		nb.int2 := pcond^[cindex];
	if (cindex = m_cond) and (ralo <> 0)
	then	begin
		cindex := 1;
		pcond := addr(table_fait^[ralo]^.fait[1]);
		ralo := table_fait^[ralo]^.ral_cond;
		end
	else	cindex := cindex + 1;
		nb.int3 := pcond^[cindex];
	if (cindex = m_cond) and (ralo <> 0)
	then	begin
		cindex := 1;
		pcond := addr(table_fait^[ralo]^.fait[1]);
		ralo := table_fait^[ralo]^.ral_cond;
		end
	else	cindex := cindex + 1;


		value := nb.rea;
		end;
	if code = p_int
	then	begin
		code := p_nombre;
		value := pcond^[cindex];
		cindex := cindex + 1;
		end;
	if code < 0
	then	niveau := -1
	else	begin
		lire_symbole(code);
		if symbole_lu[1] = '_'
		then	begin
			if nniveau = 0
			then	begin
				niv := 1;
				nniveau := 1;
				table_env^[1] := 0;
				envcour[1] := code;
				end
			else	begin
				i := top;
				niv := 0;
				while i < nniveau do
					begin
					i := i + 1;
					if code = envcour[i-top]
					then	begin
						niv := i;
						i := nniveau;
						end;
					end;
				if niv = 0
				then	begin
					niv := nniveau + 1;
					nniveau := niv;
					table_env^[nenv+niv] := 0;
					envcour[niv-top] := code;
					end;
				end;
			niveau := niv;
			end
		else	niveau := -1;
		nb_arg := table_symbole^[code].nbr_arg;
		for i := 1 to nb_arg do
			begin
			if i = 1
			then	begin
				decomp(ancien,top);
				fils := ancien;
				end
			else	begin
				decomp(nouveau,top);
				noeud^[ancien].frere := nouveau;
				ancien := nouveau;
				end;
			end;
		if codemul
		then	begin
			lire_symbole(code);
			if symbole_lu = 'write'
			then	code := p_write;
			if symbole_lu = 'writeln'
			then	code := p_writeln;
			if symbole_lu = 'writewords'
			then	code := p_wwords;
			if symbole_lu = 'writewordsln'
			then	code := p_wwln;
			if symbole_lu = 'read'
			then	code := p_read;
			if symbole_lu = 'readln'
			then	code := p_readln;
			if symbole_lu = 'putln'
			then	code := p_putln;
			if symbole_lu = 'put'
			then	code := p_put;
			end;
		end;
	end;
end;

procedure calcule_coded(regle:integer;
	var numero:integer; var numhsh:integer; var code_fait : integer);
begin
code_fait := getval(noeud^[regle].fils);
if noeud^[code_fait].code = p_point
then	code_fait := getval(noeud^[code_fait].fils);
if noeud^[code_fait].niveau <> -1
then	numhsh := 0
else	begin
	if noeud^[code_fait].code = p_nombre
	then	begin
		nb.rea := noeud^[code_fait].value;
		if (nb.rea <-32767) or (nb.rea>32767)
		then	code_fait := 0
		else	code_fait := abs(trunc(nb.rea)) mod mx_coded;
		end
	else	code_fait := noeud^[code_fait].code mod mx_coded;
	numero := table_coded[numhsh]^.tete_coded[code_fait];
	end;
end;
		(********************************************************)
		(*	ajout d'un element dans la pile de resolution	*)
		(********************************************************)
procedure ajoute_arbre(regle : integer);
var	i,reg	: integer;
	code_fait : integer;
	numhsh	: integer;
begin
if narbre >= max_arbre
then	begin
	sortie := true;
	writeln(output,'trop d''arbres');
	end
else	begin
	narbre := narbre + 1;
	if narbre > nbarbre
	then	nbarbre := narbre;
	if noeud^[regle].niveau <> -1
	then	begin
		reg := noeud^[regle].frere;
		regle := getval(regle);
		noeud^[regle].frere := reg;
		end;
	with table_arbre^[narbre] ,noeud^[regle] do
		begin
		demo := regle;
		numhsh := table_symbole^[code].phsh_coded;
		if numhsh > 0
		then	calcule_coded(regle,numero,numhsh,code_fait);
		if numhsh <= 0
		then	begin
			numero := table_symbole^[code].premier;
			info := 0;
			end
		else	begin
			info := code_fait+1;
			end;
		brother := frere;
		snoeud := nnoeud;
		senv := nenv;
		end;
	end;
end;

end.
