unit ulist;

interface
uses umain;
  procedure rend(vale	:integer;  index	:integer);
  procedure tposit;
  procedure clreol;
  procedure flat(var	pre	:integer; var	sor	:integer);
  procedure inverser(pre	:integer; var	sor:integer);
  procedure miroir(pre	:integer;var sor:integer);
  procedure telement(bac:integer);
  procedure tinclus;
  procedure tpush(co:integer);
  procedure tpop(bac:integer);
  procedure tpushdiff;
  procedure tlistens;
  procedure tflat;
  procedure tinverse;
  procedure tmiroir;
  procedure treparg;
  procedure targ(index	:integer;re :integer);
  procedure tdel4;
  procedure tinsert;
  procedure tconc;
  procedure tcompens;
  procedure tunion;
  procedure tinter;
  procedure tcomplement;
  procedure tsubstr(index	:integer;
		taille	:integer;
		posi	:integer);
  procedure anadesc(desc:integer; var descrip : tdescr; suite_desc : integer);
  procedure affmsg(msg : tstring; err : boolean; l1: integer);


implementation
uses usp,uunif;

		(****************************************)
		(*	traitement des listes		*)
		(*		et des ensembles	*)
		(*		anadesc			*)
		(*		affmsg			*)
		(*	mlist.pas	-	prolog	*)
		(****************************************)
procedure rend(vale	:integer;
		index	:integer);
		(* rend la valeur vale dans le parametre de rang index *)
var	i	:integer;
begin
for i:=1 to index-1 do
	fait1 := noeud^[fait1].frere;
fait1 := getvval(fait1);
if noeud^[fait1].niveau <> -1
then	begin
	prend_noeud(i);
	table_env^[nenv+noeud^[fait1].niveau] := i;
	with noeud^[i] do
		begin
		value:=vale;
		code:=p_nombre;
		end;
	end
else	begin
	if noeud^[fait1].code = p_nombre
	then	begin
		if noeud^[fait1].value <> vale
		then	backtrack:=true;
		end
	else	backtrack:=true;
	end;
end;

procedure tposit;
var	l,c:integer;
begin
if valeur (-1,l)
then	begin
	if valeur(-2,c)
	then	posit(l,c)
	else	backtrack:=true;
	end
else	backtrack:=true;
end;

procedure clreol;
begin
end;


procedure flat(var	pre	:integer;
		var	sor	:integer);
var	el,ele	:integer;
begin
while pre <> 0 do
	begin
	lire_element(pre,el);
	ele := getval(el);
	if ele <> 0
	then	if noeud^[ele].code=p_point
		then	flat(ele,sor)
		else	ajoute_element(el,sor);
	end;
end;


procedure inverser(pre	:integer;
	var	sor:integer);
var	el	:integer;
begin
crevide(sor);
while pre <> 0 do
	begin
	lire_element(pre,el);
	el := getval(el);
	if el <> 0
	then	ajoute_tete(el,sor);
	end;
end;


procedure miroir(pre	:integer;var sor:integer);
var	el,ele,pte	:integer;
begin
crevide(sor);
inverser(pre,sor);
pre:=sor;
while pre <> 0 do
	begin
	lire_element(pre,el);
	ele := getval(el);
	if ele <> 0
	then	begin
		if noeud^[ele].code=p_point
		then	begin
			miroir(ele,pte);
			noeud^[el].fils:=noeud^[pte].fils;
			end;
		end;
	end;
end;
(*.E+*)

procedure telement(bac:integer);
var	i	: integer;
	liste,sor	: integer;
begin		(* element (terme,liste) *)
if noeud^[fils2].code=p_point
then	begin
	empile_env;
	liste := fils2;
	with table_arbre^[narbre] do
		begin
		for i := 1 to info do
			lire_element(liste,sor);
		info := info + 1;
		end;
	lire_element(liste,sor);
	if sor <> 0
	then	begin
		if not unifier(fils1,sor)
		then	begin
			backtrack := true;
			snum := 0;
			end
		else	snum := bac;
		end
	else	backtrack := true;
	end
else	backtrack:=true;
end;

procedure tinclus;
var	el,pte1,pte2:integer;
begin		(* inclus(ensemble1,ensemble2) *)
pte1:=fils1;
pte2:=fils2;
while pte1 <> 0 do
	begin
	lire_element(pte1,el);
	el:=getval(el);
	if el <> 0
	then	begin
		if not felement(el,pte2)
		then	begin
			backtrack:=true;
			pte1:=0;
			end;
		end;
	end;
end;


procedure tpush(co:integer);
var	pre,sor	:integer;
	pte,el	:integer;
begin
pre:=table_symbole^[noeud^[fils1].code].vale;
glob :=true;
if pre=0
then	begin
	crevide(pre);
	table_symbole^[noeud^[fils1].code].vale:=pre;
	end;
if (noeud^[pre].code=p_point) or (noeud^[pre].code=p_nil)
then	begin
	if co=0
	then	ajoute_tete(fils2,pre)
	else	begin
		if noeud^[pre].frere=0
		then	begin
			pte:=pre;
			while pte <> 0 do
				begin
				noeud^[pre].frere:=pte;
				lire_element(pte,el);
				end;
			end;
		ajoute_element(fils2,pre);
		end;
	end
else	backtrack:=true;
glob:=false;
end;

procedure tpop(bac:integer);
var	pre,sor,sar	:integer;
	el	:integer;
	hold_it	:integer;
begin
pre:=table_symbole^[noeud^[fils1].code].vale;
if pre=0
then	backtrack:=true
else	begin
	if noeud^[pre].code=p_point
	then	begin
		empile_env;
		lire_element(pre,sor);
		table_symbole^[noeud^[fils1].code].vale:=pre;
		noeud^[sor].frere := 0;
		pcopy(sor,sar);
		liber_glob(sor);
		rend_liste(sar,2);
		snum := bac;	(* pour retour arriŠre *)
		end
	else	backtrack:=true;
	end;
end;


procedure tpushdiff;
var	pre	:integer;
begin
pre := table_symbole^[noeud^[fils1].code].vale;
glob:=true;
if pre=0
then	begin
	crevide(pre);
	table_symbole^[noeud^[fils1].code].vale := pre;
	end;
if (noeud^[pre].code=p_point) or (noeud^[pre].code=p_nil)
then	begin
	if not felement(fils2,pre)
	then	ajoute_tete(fils2,pre);
	end
else	backtrack:=true;
glob:=false;
end;


procedure tlistens;
var	pte,el,ele,sor:integer;
begin		(* listens (liste1,ensemble) *)
crevide(sor);
pte:=fils1;
while pte <> 0 do
	begin
	lire_element(pte,el);
	ele := getval(el);
	if ele <> 0
	then	begin
		if not felement(ele,sor)
		then	ajoute_element(el,sor);
		end;
	end;
rend_liste(sor,2);
end;


procedure tflat;
var	pre,sor:integer;
begin		(* flat (liste,liste) *)
if (noeud^[fils1].code=p_point)
or (noeud^[fils2].code=p_nil)
then	begin
	crevide(sor);
	pre:=fils1;
	flat(pre,sor);
	rend_liste(sor,2);
	end
else	backtrack:=true;
end;


procedure tinverse;
var	sor,pre	:integer;
begin		(* inverse (liste,liste) *)
if (noeud^[fils1].code=p_point)
or (noeud^[fils1].code=p_nil)
then	begin
	pre:=fils1;
	inverser(pre,sor);
	rend_liste(sor,2);
	end
else	backtrack:=true;
end;


procedure tmiroir;
var	pre,sor:integer;
begin		(* miroir (liste,liste) *)
if (noeud^[fils1].code=p_point)
or (noeud^[fils1].code=p_nil)
then	begin
	pre:=fils1;
	miroir(pre,sor);
	rend_liste(sor,2);
	end
else	backtrack:=true;
end;

procedure treparg;
var	objet	: integer;
	rang	: integer;
	fils3	: integer;
	el,sor,prec	: integer;
	i	: integer;
begin
rang := trunc(evaluation(fils1));
if rang > 0
then	begin
	fils3 := noeud^[fait2].frere;
	objet := noeud^[fils3].frere;
	prend_noeud(sor);
	noeud^[sor] := noeud^[fils2];
	fils2 := noeud^[fils2].fils;
	if fils2 = 0
	then	begin
		backtrack := true;
		i := rang;
		end
	else	i := 0;
	while i < rang do
		begin
		i := i + 1;
		prend_noeud(el);
		noeud^[el] := noeud^[fils2];
		if i = 1
		then	noeud^[sor].fils := el
		else	noeud^[prec].frere := el;
		prec := el;
		if fils2 = 0
		then	begin
			backtrack := true;
			i := rang;
			end
		else	fils2 := noeud^[fils2].frere;
		end;
	if not backtrack
	then	begin
		noeud^[el] := noeud^[objet];
		noeud^[el].frere := fils2;
		if not unifier(sor , fils3)
		then	backtrack := true;
		end;
	end
else	backtrack := true;
end;

procedure targ(index	:integer;re :integer);
var	i,rang	:integer;
	pre,el,sor,hold_it	:integer;
begin		(* first(liste,terme) *)
if noeud^[fils1].code=p_point
then	begin
	if valeur(index,index)
	then	begin
		pre:=fils1;
		el:=0;
		if index=-1
		then	begin
			while pre <> 0 do
				begin
				lire_element(pre,sor);
				if sor <> 0
				then	el:=sor;
				end;
			end
		else	begin
			for i:=1 to index do
				lire_element(pre,el);
			end;
		if el=0
		then	backtrack:=true
		else	begin
			locopy(el,sor);
			rend_liste(sor,re);
			end;
		end
	else	backtrack:=true;
	end
else	begin
	if index =-2
	then	begin
		rang := trunc(evaluation(fils1));
		if (rang>0) and (rang<1000)
		then	begin
			el := noeud^[fils2].fils;
			for i:=1 to rang-1 do
				begin
				if el <> 0
				then	el := noeud^[el].frere;
				end;
			if el = 0
			then	backtrack := true
			else	if not unifier(el,noeud^[fait2].frere)
				then	backtrack := true;
			end
		else	backtrack:=true;
		end
	else	backtrack:=true;
	end;
end;

procedure tdel4;
var	el,sor	: integer;
	i,p,l	: integer;
begin
crevide(sor);
p := trunc(evaluation(fils2));
l := trunc(evaluation(noeud^[fait2].frere));
i := 0;
while fils1 <> 0 do
	begin
	i := i + 1;
	lire_element(fils1,el);
	if (i>=p) and (i<p+l)
	then	el := 0;
	if el <> 0
	then	ajoute_element(el,sor);
	end;
rend_liste(sor,4);
end;

procedure tinsert;
var	el,sor	: integer;
	i,p,k	: integer;
begin
crevide(sor);
p := trunc(evaluation(noeud^[fait2].frere));
i := 0;
k := 0;
while fils2 <> 0 do
	begin
	i := i + 1;
	if i = p
	then	begin
		k := 1;
		while fils1 <> 0 do
			begin
			lire_element(fils1,el);
			if el <> 0
			then	ajoute_element(el,sor);
			end;
		end;
	lire_element(fils2,el);
	if el <> 0
	then	ajoute_element(el,sor);
	end;
if k = 0
then	begin
	while fils1 <> 0 do
		begin
		lire_element(fils1,el);
		if el <> 0
		then	ajoute_element(el,sor);
		end;
	end;
rend_liste(sor,4);
end;

procedure tconc;
var	pte1,pte2,el,sor	:integer;
begin		(* conc (liste1,liste2,liste3)*)
pte1:=fils1;
pte2:=fils2;
crevide(sor);
while pte1 <> 0 do
	begin
	lire_element(pte1,el);
	if el <> 0
	then	ajoute_element(el,sor);
	end;
while pte2 <> 0 do
	begin
	lire_element(pte2,el);
	if el <> 0
	then	ajoute_element(el,sor);
	end;
rend_liste(sor,3);
end;

procedure tcompens;
var	pte1,pte2,el	:integer;
begin		(* compens (ensemble1,ensemble2) *)
tinclus;
if not backtrack
then	begin
	pte1:=fils1;
	pte2:=fils2;
	fils1:=pte2;
	fils2:=pte1;
	tinclus;
	end;
end;

procedure tunion;
		(* union (ensemble1,ensemble2,ensemble3) *)
var	pte1,pte2,el,sor	:integer;
begin
pte1:=fils1;
pte2:=fils2;
crevide(sor);
while pte1 <> 0 do
	begin
	lire_element(pte1,el);
	if el <> 0
	then	ajoute_element(el,sor);
	end;
while pte2 <> 0 do
	begin
	lire_element(pte2,el);
	if el <> 0
	then	begin
		if not felement(el,sor)
		then	ajoute_element(el,sor);
		end;
	end;
rend_liste(sor,3);
end;

procedure tinter;
var	sor,pte1,pte2:integer;
	el:integer;
begin		(* inter (ensemble1,ensemble2,ensemble3) *)
crevide(sor);
pte1:=fils1;
pte2:=fils2;
while pte1 <> 0 do
	begin
	lire_element(pte1,el);
	if el<> 0
	then	if felement(el,pte2)
		then	ajoute_element(el,sor);
	end;
rend_liste(sor,3);
end;

procedure tcomplement;
	var	sor	:integer;
	pte1,pte2,el	:integer;
begin   (* complement (ensemble1,reference,ensemble2) *)
crevide(sor);
pte1:=fils1;
pte2:=fils2;
while pte2 <> 0 do
	begin
	lire_element(pte2,el);
	if el<> 0
	then	if not felement(el,pte1)
		then	ajoute_element(el,sor);
	end;
rend_liste(sor,3);
end;

procedure tsubstr(index	:integer;
		taille	:integer;
		posi	:integer);
var	pre,el,sor,i	:integer;
begin
backtrack:=true;
if valeur(index,index)
then	begin
	if valeur(taille,taille)
	then	begin
		if (index>=-1) and (taille>=0)
		then	begin
			pre:=fils1;
			if index=-1
			then	begin
				index:=0;
				while pre <> 0 do
					begin
					lire_element(pre,el);
					if el <> 0
					then	index:=index+1;
					end;
				index:=index-taille+1;
				pre:=fils1;
				end;
			backtrack:=false;
			for i:=1 to index-1 do
				lire_element(pre,el);
			crevide(sor);
			if pre <> 0
			then	begin
				i := 0;
				while i < taille do
					begin
					i := i + 1;
					lire_element(pre,el);
					if el <> 0
					then	ajoute_element(el,sor)
					else	i := taille;
					end;
				end;
			rend_liste(sor,posi);
			end;
		end;
	end;
end;

procedure anadesc(desc:integer; var descrip : tdescr; suite_desc : integer);
var	sep	: boolean;
	ll,cc	: integer;
	des,sor	: integer;
	nb	: real;
	incmenu	: boolean;
	el	: integer;
begin
if suite_desc <> 0
then	begin
	suite_desc := noeud^[desc].frere;
	suite_desc := getvval(suite_desc);
	end;
desc := getvval(desc);
sep := false;
incmenu := false;
nummenu := 1;
with descrip do
	begin
	min := minint;
	max := maxint;
	typ := p_int0;
	listword := 0;
	with des1 do
		begin
		l:= 0;	c:=0;
		tc:=-1; bc:=-1;
		v:=0;
		num := -1;
		numer := -1;
		rz := true;
		end;
	with des2 do
		begin
		l:= 0;	c:=0;
		ls:=0;	cs:=0;
		tc:=-1; bc := -1;
		v:=0;
		num := -1;
		numer := -1;
		rz := true;
		end;
	menuf := true;
	ppr := true;
	oblig := true;
	antic := false;
	while desc <> 0 do
		begin		(* analyse de la description du parametre *)
		if noeud^[desc].code = p_point
		then	begin
			lire_element(desc,sor);
			sor := getval(sor);
			end
		else	begin
			sor := desc;
			desc := 0;
			end;
		if sor <> 0
		then	begin
			des := noeud^[sor].code;
			case des of
				p_nil	:begin
					end;
				p_coupe0	: sep := true;
				p_videonor	: begin
						if sep
						then	des2.v := p_videonor
						else	des1.v := p_videonor;
						end;
				p_videoinv	: begin
						if sep
						then	des2.v := p_videoinv
						else	des1.v := p_videoinv;
						end;
				p_clreol	: if sep
						then	des2.rz := true
						else	des1.rz := true;
				p_all		: if sep
						then	des2.rz := false
						else	des1.rz := false;
				p_int0		: typ := p_int0;
				p_real0		: typ := p_real0;
				p_word		: typ := p_word;
				p_list		: begin
						ll := noeud^[sor].fils;
						ll := getvval(ll);
						listword := ll;
						end;
				p_point		: listword := sor;
				p_words		: typ := p_words;
				p_yesno		: typ := p_yesno;
				p_time		: typ := p_time;
				p_date		: typ := p_date;
				p_oblig		: oblig := true;
				p_facul		: oblig := false;
				p_nosilent	: ppr := true;
				p_silent	: ppr := false;
			 (*	p_numerote	: begin
						if des1.num=-1
						then	begin
						des1.numer
						 := fenetre[curfen].val_menu;
						menuf := false;
							end;
						end;    *)
				p_num		: begin
					  (*	ll := noeud^[sor].fils;
						ll := trunc(evaluation(ll));
						nummenu := ll;
						with fenetre[curfen] do
							begin
						des1.l := lig_cous+(ll-1)*ecart;
						des1.c := col_cour;
						des2.l := des1.l;
						des2.c := col_val;
						des2.ls := des2.l;
						des2.cs := col_saisie;
						des1.num := 0;
						des1.numer := -1;
							end;    *)
						end;
				p_cursor	: begin
						ll := noeud^[sor].fils;
						cc := noeud^[ll].frere;
						ll := trunc(evaluation(ll));
						cc := trunc(evaluation(cc));
						if sep
						then	begin
							des2.l := ll;
							des2.c := cc;
							des2.ls := ll;
							des2.cs := cc;
							end
						else	begin
							des1.l := ll;
							des1.c := cc;
							end;
						end;
				p_next	: begin
			    (*		with fenetre[curfen] do
						begin
						des1.l := lig_cour;
						des1.c := col_cour;
						if des2.c = 0
						then	begin
							des2.c := col_val;
							des2.cs:= col_saisie;
							end;
						des2.l := lig_cour;
						des2.ls := lig_cour;
						lig_cour := lig_cour + ecart;
						incmenu := true;
						end;   *)
					end;
				p_textcolor	: begin
					if not nocolor
					then	begin
						ll := noeud^[sor].fils;
						ll := trunc(evaluation(ll));
						if sep
						then	des2.tc := ll
						else	des1.tc := ll;
						end;
					end;
				p_backcolor	: begin
					if not nocolor
					then	begin
						ll := noeud^[sor].fils;
						ll := trunc(evaluation(ll));
						if sep
						then	des2.bc := ll
						else	des1.bc := ll;
						end;
					end;
				else
						begin
						el := getvval(sor);
						if noeud^[el].code = p_point
						then	listword := el
						else	begin
							nb := evaluation(sor);
							if min = minint
							then	min := nb
							else	max := nb;
							end;
						end;
				end;
			end;
		if (desc = 0) and (suite_desc <> 0)
		then	begin
			sep := true;
			desc := suite_desc;
			suite_desc := 0;
			end;
		end;
 (*	if incmenu
	then	fenetre[curfen].val_menu := fenetre[curfen].val_menu+1;   *)
	if (typ = p_word) or (typ = p_words)
	then	begin
		if min = minint
		then	begin
			min := 0;
			max := 80;
			end;
		if (min=0) and oblig
		then	 min := 1;
		if max > ncmot
		then	max := ncmot;
		end;
	end;
end;

procedure affmsg(msg : tstring; err : boolean; l1: integer);
begin
(*if l1 <> 0
then	begin
	posit(l24,1);
	clreol;
	end;
highvideo;    *)
if err
then	write(output,'  *** - ')
else	write(output,'  ');
write(output,msg,'  ');
(*lowvideo;
remet_couleur;    *)
if err
then	indphrase := length(phrase);

if l1 = 0
then	writeln(output);
end;

end.
