unit uunif;

interface
uses umain;
  procedure empile_env;
  function unifier(fait1:integer; fait2:integer) : boolean;
  procedure ajoute_tete(		el		:integer;
			var	sor		:integer);
  procedure ajoute_element(	el		:integer;
				sor		:integer);
  procedure lire_element( var	pre	:integer;
			var	el	:integer);
  function comp(el,ele:integer):boolean;
  function felement(el:integer; lis:integer):boolean;
  function numeric(objet : integer) : boolean;
  function tlocate(fils1,fils2,index	:integer) : integer;
  function traitopt(fils1 : integer) : integer;
  function tlength(fils1 : integer) : integer;
  function evaluation(objet : integer) : real;
  procedure affecte(fait1,fait2 : integer; uni : integer);


implementation
uses usp;
	(****************************************)
		(*	unification			*)
		(*	evaluation arithmetique		*)
		(*	affectation d'une valeur	*)
		(*	munif.pas	-	prolog	*)
		(****************************************)

procedure empile_env;
var	i	: integer;
begin		(* pour rendre un predicat predefini backtrackable *)
oldenv := nenv;
nenv := nenv+nniveau;
if nenv+nniveau > max_env
then	begin
	nenv := oldenv;
	sortie := true;
	writeln(output,'trop d''environnements');
	end
else	begin
	for i := 1 to nniveau do
		table_env^[nenv+i] := table_env^[oldenv+i];
	end;
end;
		(****************************************)
		(*	unification de deux objets	*)
		(****************************************)
function unifier(fait1:integer; fait2:integer) : boolean;
var	suiv1,suiv2	: integer;
	fai1,fai2	: integer;
	unif		: boolean;

function comparer(fon1: integer ; fon2 : integer) : boolean;
var	idem		: boolean;
	f1,f2		: integer;
	niv1,niv2	: integer;
	nniv1,nniv2	: integer;

begin
f1 := noeud^[fon1].code;
f2 := noeud^[fon2].code;
niv1 := noeud^[fon1].niveau;
niv2 := noeud^[fon2].niveau;
if (f1 = f2) and (niv1 = niv2)
then	begin
	if f1 = p_nombre
	then	begin
		if noeud^[fon1].value = noeud^[fon2].value
		then	idem := true
		else	idem := false;
		end
	else	idem := true;
	end
else	begin
	if table_symbole^[f1].symbol^[1] = '_'
	then	begin
		idem := true;
		if table_symbole^[f2].symbol^[1] = '_'
		then	begin	(* f1 et f2 variables *)
			nniv1 := niv1;
			nniv2 := niv2;
			if noeud^[fon1].fils <> 0
			then	begin
				if noeud^[fon2].fils = 0
				then	nniv2 := nniv1 + 1;
				end
			else	if noeud^[fon2].fils <> 0
				then	nniv1 := nniv2 + 1;
			if nniv1 < nniv2
			then	table_env^[nenv+niv2] := fon1
			else	table_env^[nenv+niv1] := fon2;
			end
		else	begin	(* f1 variable et f2 defini *)
			table_env^[nenv+niv1] := fon2;
			end;
		end
	else	begin
		if table_symbole^[f2].symbol^[1] = '_'
		then	begin
			idem := true;
			if table_symbole^[f1].symbol^[1] = '_'
			then	begin	(* f1 et f2 variables *)
				nniv1 := niv1;
				nniv2 := niv2;
				if noeud^[fon1].fils <> 0
				then	begin
					if noeud^[fon2].fils = 0
					then	nniv2 := nniv1 + 1;
					end
				else	if noeud^[fon2].fils <> 0
					then	nniv1 := nniv2 + 1;
				if nniv1 < nniv2
				then	table_env^[nenv+niv2] := fon1
				else	table_env^[nenv+niv1] := fon2;
				end
			else	begin	(* f1 defini et f2 variable *)
				table_env^[nenv+niv2] := fon1;
				end;
			end
		else	idem := false;
		end;
	end;
comparer := idem;
end;

begin		(* code de unifier *)
fai1 := getval(fait1);
fai2 := getval(fait2);
unif := false;
if (noeud^[fai1].niveau <> -1) and (noeud^[fai1].fils = 0)
then	unif := comparer(fai1,fai2)
else	begin
	if (noeud^[fai2].niveau <> -1) and (noeud^[fai2].fils = 0)
	then	unif := comparer(fai2,fai1)
	else	begin
		if comparer(fai1,fai2)
		then	begin
			suiv1 := noeud^[fai1].fils;
			suiv2 := noeud^[fai2].fils;
			unif := true;
			while suiv1 <> 0 do
				begin
				if suiv2 = 0
				then	begin
					suiv1 := 0;
					unif := false;
					end
				else	begin
					if unifier(suiv1,suiv2)
					then	begin
						suiv1 := noeud^[suiv1].frere;
						suiv2 := noeud^[suiv2].frere;
						end
					else	begin
						unif := false;
						suiv1 := 0;
						end;
					end;
				end;
			if suiv1 <> suiv2
			then	unif := false;
			end
		else	unif := false;
		end;
	end;
unifier := unif;
end;

procedure ajoute_tete(		el		:integer;
			var	sor		:integer);
var	pte	:integer;
begin
if (el <> 0) and (noeud^[el].code <> p_nil)
then	begin
	if glob
	then	prend_glob(pte)
	else	prend_noeud(pte);
	if noeud^[sor].code=p_nil
	then	begin
		noeud^[pte].code:=p_nil;
		noeud^[sor].code:=p_point;
		end
	else	begin
		noeud^[pte].fils:=noeud^[sor].fils;
		noeud^[pte].code:=p_point;
		end;
	locopy(el,noeud^[sor].fils);
	noeud^[noeud^[sor].fils].frere:=pte;
	end;
end;

procedure ajoute_element(	el		:integer;
				sor		:integer);
var	pte,finc	:integer;
begin
if (el <> 0) and (noeud^[el].code <> p_nil)
then	begin
	if glob
	then	prend_glob(pte)
	else	prend_noeud(pte);
	if noeud^[sor].code <> p_nil
	then	finc:=noeud^[sor].frere
	else	finc:=sor;
	noeud^[finc].code:=p_point;
	noeud^[sor].frere:=pte;
	noeud^[pte].code:=p_nil;
	locopy(el,noeud^[finc].fils);
	noeud^[noeud^[finc].fils].frere:=pte;
	end;
end;

procedure lire_element( var	pre	:integer;
			var	el	:integer);
begin
if pre=0
then	el:=0
else	begin
	el:=noeud^[pre].fils;
	if el=0
	then	pre:=0
	else	begin
		pre:=noeud^[el].frere;
		pre := getval(pre);
		end;
	end;
end;

function comp(el,ele:integer):boolean;
var	fel	:boolean;
	v1,v2	:integer;
begin
fel:=true;
el := getval(el);
ele := getval(ele);
if noeud^[el].code = noeud^[ele].code
then	begin
	if (noeud^[el].value=noeud^[ele].value)
	or (noeud^[el].code <> p_nombre)
	then	begin
		if noeud^[el].code=p_point
		then	begin
			while el<> 0 do
				begin
				lire_element(el,v1);
				lire_element(ele,v2);
				if (v1=0) or (v2=0)
				then	begin
					el:=0;
					if v1 <> v2
					then	fel:=false;
					end
				else	begin
					if not comp(v1,v2)
					then	begin
						el:=0;
						fel:=false;
						end;
					end;
				end;
			end;
		end
	else	fel:=false;
	end
else	fel:=false;
comp:=fel;
end;

function felement(el:integer; lis:integer):boolean;
	(* l'objet el est-il element de la liste lis, that is the question *)
var	ele:integer;
	fel:boolean;
begin
fel:=false;
el := getval(el);
while lis <> 0 do
	begin
	lire_element(lis,ele);
	ele := getval(ele);
	if ele <> 0
	then	begin
		if comp(el,ele)
		then	begin
			lis:=0;
			fel:=true;
			end;
		end;
	end;
felement:=fel;
end;

		(********************************************************)
		(*
		(*	evaluation d'une expression arithmetique	*)
		(********************************************************)
function numeric(objet : integer) : boolean;
var	num	: boolean;
	fon	: integer;
begin
num := false;
fon := getvval(objet);
fon := noeud^[fon].code;
if (fon = p_nombre) or (fon = p_locat3) or (fon = p_length) or (fon = p_ord)
or (fon = p_option)
then	num := true
else	begin
	if fon >= p_plus
	then	begin
		if (fon <= p_puiss) or ((fon>=p_div) and (fon<=p_getdot))
		then	begin
			if numeric(noeud^[objet].fils)
			and numeric(noeud^[noeud^[objet].fils].frere)
			then	num := true;
			end
		else	begin
			if (fon >= p_round) and (fon <= p_random)
			then	begin
				if numeric(noeud^[objet].fils)
				then	num := true;
				end
			else	begin
				if (fon >= p_wherex) and (fon <= p_index)
				then	num := true;
				end;
			end;
		end;
	end;
numeric := num;
end;

function tlocate(fils1,fils2,index	:integer) : integer;
var	pre1,pre2,spre1,spre2	:integer;
	i,p		:integer;
	fin		:boolean;
	el,el1,el2	:integer;
begin		(* locate (chaine,chaine2,index) *)
p := 0;
if (noeud^[fils1].code=p_point)
or (noeud^[fils1].code=p_nil)
then	begin
	pre1:=fils1;
	pre2:=fils2;
	if index > 1
	then	begin
		for i:=1 to index-1 do
			lire_element(pre2,el);
		p:=index;
		end
	else	p := 1;
	if pre2 = 0
	then	p := 0
	else	begin
		spre2:=pre2;
		spre1:=pre1;
		fin := false;
		while not fin do
			begin
			if pre1=0
			then	fin:=true
			else	begin
				lire_element(pre1,el1);
				if el1 = 0
				then	fin := true
				else	if pre2=0
				then	begin
					fin:=true;
					p := 0;
					end
				else	begin
					lire_element(pre2,el2);
					if not comp(el1,el2)
					then	begin
						pre1:=spre1;
						pre2:=spre2;
						lire_element(pre2,el1);
						spre2:=pre2;
						p:=p+1;
						if pre2=0
						then	begin
							fin:=true;
							p := 0;
							end;
						end;
					end;
				end;
			end;
		end;
	end;
tlocate := p;
end;

function traitopt(fils1 : integer) : integer;
var	i,v	: integer;
	sym	: ttstring;
begin
i := noeud^[fils1].code;
lire_symbole(i);
sym := symbole_lu;
if sym = 'ioresult'
then	v := ioresu
else	begin
	v := 0;
	end;
traitopt := v;
end;

function tlength(fils1 : integer) : integer;
var	pre,el	: integer;
	m	: integer;
begin		(* length (liste) *)
m := 0;
if (noeud^[fils1].code=p_point)
or (noeud^[fils1].code=p_nil)
then	begin		(* une liste *)
	pre:=fils1;
	m:=-1;
	while pre <> 0 do
		begin
		m:=m+1;
		lire_element(pre,el);
		end;
	end
else	begin		(* une structure ou un identificateur *)
	m := 1;
	pre := noeud^[fils1].fils;
	while pre <> 0 do
		begin
		m := m + 1;
		pre := noeud^[pre].frere;
		end;
	end;
tlength := m;
end;

function evaluation(objet : integer) : real;
var	fils1,fils2,fait2	: integer;
	i	: integer;
	x,j	: real;
begin
objet := getvval(objet);
fils1 := noeud^[objet].fils;
x:=0;
if fils1 <> 0
then	begin
	fait2 := noeud^[fils1].frere;
	fils2 := getvval(fait2);
	fils1 := getvval(fils1);
	x := evaluation(fils1);
	end
else	fils2 := 0;
backtrack := false;
case noeud^[objet].code of
	p_nombre	: evaluation := noeud^[objet].value;
	p_plus 		: evaluation := x + evaluation(fils2);
	p_moins		: evaluation := x - evaluation(fils2);
	p_moinsu	: evaluation := -x;
	p_mul  		: evaluation := x * evaluation(fils2);
	p_divise	: evaluation := x / evaluation(fils2);
	p_puiss 	: if x = 0.0
		then	evaluation := 0
		else	evaluation := exp(evaluation(fils2) * ln(x) );

	p_random	: evaluation := random(trunc(x))+1;

       (*	p_wherex	: evaluation := wherex;
	p_wherey	: evaluation := wherey;     *)
	p_pi		: evaluation := 3.1415;
	p_index		: evaluation := last_index;
	p_ioresult	: evaluation := ioresu;
     (*	p_option	: evaluation := traitopt(fils1); *)

	p_mod  :evaluation:=trunc(x) mod trunc(evaluation(fils2));
	p_div  :evaluation:=trunc(x) div trunc(evaluation(fils2));
	p_round		: begin
			if (x>=minint) and (x<=maxint)
			then	evaluation:=round(x)
			else	backtrack := true;
			end;
	p_trunc		:begin
			if (x>=minint) and (x<=maxint)
			then	evaluation:=trunc(x)
			else	backtrack := true;
			end;
	p_ln		:evaluation:=ln(x);
	p_log		:evaluation := ln(x);
	p_inte		:evaluation := int(x);
	p_frac		:evaluation := frac(x);
	p_fact		:begin
			j := 1;
			for i := 1 to trunc(x) do
				j := j * i;
			evaluation := j;
			end;
	p_exp		:evaluation:=exp(x);
	p_sin		:evaluation:=sin(x);
	p_cos		:evaluation:=cos(x);
	p_tg		:evaluation:=sin(x) / cos(x);
	p_abs		:evaluation:=abs(x);
	p_sign		:if x<0
			then	evaluation := -1
			else	evaluation :=1;
	p_arctg		:evaluation:=arctan(x);
	p_arccos	:evaluation:=arctan(sqrt(1 - sqr(x)) / x);
	p_arcsin	:evaluation:=arctan(x / sqrt(1 - sqr(x)));
	p_sh		:evaluation:=(exp(x) - exp(-x)) / 2;
	p_ch		:evaluation:=(exp(x) + exp(-x)) / 2;
	p_th		:evaluation:=(exp(2*x) - 1) / (exp(2*x) + 1);
	p_arcsh		:evaluation:=ln(x + sqrt((x * x) + 1));
	p_arcch		:evaluation:=ln(x + sqrt((x * x) - 1));
	p_arcth		:evaluation:=0.5 + ln((1 + x) / (1 - x));
	p_sqrt		:evaluation:= sqrt(x);
	p_ord		:begin
			fils2 := noeud^[fils1].code;
			lire_symbole(fils2);
			evaluation:=ord(symbole_lu[1]);
			end;
	p_length	:evaluation:=tlength(fils1);
	p_locat2	:evaluation:=tlocate(fils1,fils2,1);
	p_locat3	:evaluation:=tlocate(fils1,fils2,
				trunc(evaluation(noeud^[fait2].frere)));
       (*	p_param_line	:begin
			with fenetre[curfen] do
				begin
				evaluation := ecart*(x-1) + lig_cous;
				end;
			end;   *)
	p_max_fait	: evaluation := max_fait;

	else	begin
		backtrack := true;
		evaluation := objet;
		end;
	end;
end;

(*.m divprol *)
		(*****************************************************)
		(*	affectation d'une valeur a un identificateur *)
		(*****************************************************)
procedure affecte(fait1,fait2 : integer; uni : integer);
var	i,vl : integer;
	v : real;
begin
if noeud^[fait1].niveau = -1
then	begin
	if noeud^[fait1].code = p_nombre
	then	begin
		if uni = 1
		then	begin
			v := evaluation(fait2);
			if v = noeud^[fait1].value
			then	backtrack := false
			else	backtrack := true;
			end
		else	begin
			if unifier(fait1,fait2)
			then	backtrack := false
			else	backtrack := true;
			end;
		end
	else	begin
		with table_symbole^[noeud^[fait1].code] do
			begin
			vl := vale;
			if uni = 0
			then	begin
				glob := true;
				locopy(fait2 , vale);
				glob := false;
				end
			else	begin
				v := evaluation(fait2);
				if not backtrack
				then	begin
					prend_glob(vale);
					noeud^[vale].code := p_nombre;
					noeud^[vale].value := v;
					end
				else	begin
					backtrack := false;
				if noeud^[fait2].fils = 0
				then	begin
					if uni = 2
					then	i := table_symbole^
						[noeud^[fait2].code].vale
					else	i := getvval(fait2);
					if i <> 0
					then	fait2 := i;
					end;
				glob := true;
			locopy(fait2 , table_symbole^[noeud^[fait1].code].vale);
					glob := false;
					end;
				end;
			liber_glob(vl);
			end;
		end;
	end
else	begin
	if uni = 0
	then	table_env^[nenv+noeud^[fait1].niveau] := fait2
	else	begin
		v := evaluation(fait2);
		if not backtrack
		then	begin
			prend_noeud(i);
			with noeud^[i] do
				begin
				code := p_nombre;
				value := v;
				end;
			end
		else	begin
			backtrack := false;
			if noeud^[fait2].fils = 0
			then	begin
				if uni = 2
				then	i := table_symbole^
						[noeud^[fait2].code].vale
				else	i := getvval(fait2);
				if i <> 0
				then	fait2 := i;
				end;
			locopy(fait2 , i);
			end;
		table_env^[nenv+noeud^[fait1].niveau] := i;
		end;
	end;
end;

end.
