program arbre_syntaxique;

	const
		CoinG = 50;
		CoinH = 50;
		CoinD = 500;
		CoinB = 350;

	type
		ChaineCourte = string[20];   {longueur maximale d'un identificateur}
		ChaineLongue = string;          {longueur maximale d'une expression ou d'un message d'erreur}
		Type_lexeme = (operateur, nombre, identificateur, par_ouv, par_fer, fin, inconnu);
		Lexeme = record
				case genre : Type_lexeme of
					operateur: (
							op: char
					);
					nombre: (
							valeur: integer
					);
					identificateur: (
							nom: ChaineCourte
					)
			end;
		Arbre = ^Noeud;
		Noeud = record
				case genre : Type_lexeme of
					operateur: (
							op: char;
							filsG, filsD: Arbre
					);
					nombre: (
							valeur: integer
					);
					identificateur: (
							nom: ChaineCourte
					)
			end;

	var
		pos, max_pos: integer;
		phrase, message_erreur: ChaineLongue;
		lex: Lexeme;
		expr: Arbre;
{--------------------------------------------------------------------------------}
	procedure LireLexeme;
		var
			b: boolean;
			valeur: integer;
			nom: ChaineCourte;
	begin
		b := (pos <= max_pos);
		if b then
			b := (phrase[pos] in [' ']);
		while b do
			begin
				write(phrase[pos]);
				pos := pos + 1;
				b := (pos <= max_pos);
				if b then
					b := (phrase[pos] in [' ']);
			end;
		if pos > max_pos then
			begin
				write(' ');
				lex.genre := fin
			end
		else
			case phrase[pos] of
				'0'..'9': 
					begin
						valeur := 0;
						repeat
							valeur := valeur * 10 + ord(phrase[pos]) - ord('0');
							pos := pos + 1;
							write(' ');
							b := (pos <= max_pos);
							if b then
								b := (phrase[pos] in ['0'..'9']);
						until not b;
						lex.genre := nombre;
						lex.valeur := valeur
					end;
				'+', '-', '*', '/': 
					begin
						lex.genre := operateur;
						lex.op := phrase[pos];
						pos := pos + 1;
						write(' ')
					end;
				'A'..'Z', 'a'..'z': 
					begin
						nom := '';
						repeat
							nom := concat(nom, phrase[pos]); {sous PC mettre nom:=nom+phrase[pos]}
							pos := pos + 1;
							write(' ');
							b := (pos <= max_pos);
							if b then
								b := (phrase[pos] in ['0'..'9', 'A'..'Z', '_', 'a'..'z']);
						until not b;
						lex.genre := identificateur;
						lex.nom := nom
					end;
				'(': 
					begin
						lex.genre := par_ouv;
						pos := pos + 1;
						write(' ')
					end;
				')': 
					begin
						lex.genre := par_fer;
						pos := pos + 1;
						write(' ')
					end;
				otherwise
					begin
						lex.genre := inconnu;
						message_erreur := 'lexeme inconnu';
						write(' ')
					end
			end
	end;
{-----------------creation d'un noeud nombre ou identificateur------------------------}
	function valeur_unaire (lex: Lexeme): Arbre;
		var
			e: Arbre;
	begin
		new(e);
		e^.genre := lex.genre;
		case lex.genre of
			nombre: 
				e^.valeur := lex.valeur;
			identificateur: 
				e^.nom := lex.nom
		end;
		valeur_unaire := e
	end;
{---------------------------creation d'un noeud operateur----------------------------}
	function operation_binaire (op: char; filsG, filsD: Arbre): Arbre;
		var
			e: Arbre;
	begin
		new(e);
		e^.genre := operateur;
		e^.op := op;
		e^.filsG := filsG;
		e^.filsD := filsD;
		operation_binaire := e
	end;
{----------------------creation d'un noeud nombre egal a zero------------------------}
	function valeur_nulle: Arbre;
		var
			lex: Lexeme;
	begin
		lex.genre := nombre;
		lex.valeur := 0;
		valeur_nulle := valeur_unaire(lex)
	end;

{----------------------------------descente recursive-----------------------------}

	function Expression: Arbre;
	forward;

	function Facteur: Arbre;
		var
			e: Arbre;
	begin
		case lex.genre of
			nombre, identificateur: 
				begin
					e := valeur_unaire(lex);
					LireLexeme
				end;
			par_ouv: 
				begin
					LireLexeme;
					e := Expression;
					if e <> nil then
						if lex.genre = par_fer then
							LireLexeme
						else
							begin
								message_erreur := 'parenthese fermante attendue !';
								e := nil
							end
				end;
			otherwise
				begin
					if lex.genre <> inconnu then
						message_erreur := 'ca n''a pas de sens !';
					e := nil
				end
		end;
		Facteur := e
	end;

	function Terme: Arbre;
		var
			e, e_d: Arbre;
			op: char;
	begin
		e := Facteur;
		if (e <> nil) and (lex.genre = operateur) and ((lex.op = '*') or (lex.op = '/')) then
			begin
				op := lex.op;
				LireLexeme;
				e_d := Terme;
				if e_d <> nil then
					e := operation_binaire(op, e, e_d)
				else
					e := nil
			end;
		Terme := e
	end;

	function Expression: Arbre;
		var
			e, e_d: Arbre;
			op: char;
	begin
		e := Terme;
		if (e <> nil) and (lex.genre = operateur) and ((lex.op = '+') or (lex.op = '-')) then
			begin
				op := lex.op;
				LireLexeme;
				e_d := Expression;
				if e_d <> nil then
					e := operation_binaire(op, e, e_d)
				else
					e := nil
			end;
		Expression := e
	end;

	function derive (e: Arbre; nom: ChaineCourte): Arbre;
		var
			e_derivee, e_g, e_d: Arbre;
	begin
		case e^.genre of
			nombre: 
				e_derivee := valeur_nulle;
			identificateur: 
				if e^.nom <> nom then
					e_derivee := valeur_nulle
				else
					begin
						new(e_derivee);
						e_derivee^.genre := nombre;
						e_derivee^.valeur := 1
					end;
			operateur: 
				case e^.op of
					'+', '-': 
						e_derivee := operation_binaire(e^.op, derive(e^.filsG, nom), derive(e^.filsD, nom));
					'*': 
						begin
							e_g := operation_binaire('*', derive(e^.filsG, nom), e^.filsD);
							e_d := operation_binaire('*', e^.filsG, derive(e^.filsD, nom));
							e_derivee := operation_binaire('+', e_g, e_d)
						end;
					'/': 
						begin
							e_g := operation_binaire('*', derive(e^.filsG, nom), e^.filsD);
							e_d := operation_binaire('*', e^.filsG, derive(e^.filsD, nom));
							e_g := operation_binaire('-', e_g, e_d);
							e_d := operation_binaire('*', e^.filsD, e^.filsD);
							e_derivee := operation_binaire('/', e_g, e_d)
						end
				end
		end;
		derive := e_derivee
	end;
{---------------------------------------------------------------------------------}
	procedure initialisation;
		var
			r: Rect;
	begin
		SetRect(r, CoinG, CoinH, CoinD, CoinB);
		SetTextRect(r);
		ShowText
	end;

	function lire_expression: boolean;
	begin
		writeln('Entrez une expression ou [return] :');
		write('> ');
		readln(phrase);
		if phrase <> '' then
			begin
				pos := 1;
				write(' ');
				max_pos := length(phrase);
				message_erreur := ''
			end;
		lire_expression := phrase <> ''
	end;

	procedure afficher_expression (e: Arbre);
	begin
		if e <> nil then
			case e^.genre of
				operateur: 
					begin
						write('(');
						afficher_expression(e^.filsG);
						write(e^.op : 2);
						afficher_expression(e^.filsD);
						write(')');
					end;
				nombre: 
					write(e^.valeur : 2);
				identificateur: 
					write(e^.nom)
			end
	end;
{--------------------------------------------------------------------------}
	function Analyse: Arbre;
		var
			e: Arbre;
	begin
		LireLexeme;
		e := Expression;
		if (e <> nil) and (lex.genre = fin) then
			begin
				writeln;
				write('exp = ');
				afficher_expression(e);
				writeln;
			end
		else
			begin
				if (e <> nil) and (lex.genre <> inconnu) then
					message_erreur := 'mauvaise syntaxe';
				writeln('^');
				writeln('Erreur : ', message_erreur)
			end;
		writeln;
		Analyse := e
	end;
{--------------------------------------------------------------------------}
	procedure deriver_expression (e: Arbre);
		var
			nom: ChaineCourte;
	begin
		repeat
			writeln('-> dˇrivation : entrez le nom d''une variable ou [return] : ');
			write('> ');
			readln(nom);
			if nom <> '' then
				begin
					write('e''(', nom, ') = ');
					afficher_expression(derive(e, nom));
					writeln
				end
		until nom = '';
		writeln;
	end;
{--------------------------------------------------------------------------}
begin
	initialisation;
	while lire_expression do
		begin
			expr := Analyse;
			if expr <> nil then
				deriver_expression(expr)
		end
end.