{ извлечение объекта из стека
  возвращает указатель на данные }
function TStack.pop: pointer;
var p: PStackItem;
begin
	if pTop <> nil then begin
		p := pTop;			{ сохраняем указатель на вершину }
		pop := p^.data;		{ возвращаем данные }
		pTop := p^.next;	{ новая вершина }
		dispose( p );		{ удаляем извлеченный элемент }
	end
	else
		pop := nil;
end;

BEGIN
	pBrackets := nil;
	readBrackets;		{ читаем скобки }
	if pBrackets <> nil then begin
		expr := readExpression;	{ читаем выражение }
		writeln( 'Parsing expression:' );
		writeln( expr );
		writeln( msg[parse( expr )] );	{ анализ и сообщение }
	end;
	freeBrackets;
END.

{
Задано m пар не повторяющихся символов, воспринимаемых как скобочные
пары, т.е. если (a,b) - одна из пар, то a- левая скобка, b-
соответствующая правая скобка. Вводится текст, состоящий из любой
последовательности символов и пробела. Текст считается корректным,
если соблюдаются скобочные правила: за левой скобкой рано или поздно
следует соответствующая правая скобка. Предусмотреть произвольную
вложенность скобок. Надо определить корректность любого введенного
текста. И текст и пары скобок считать из входных файлов. В программе
использовать стек.
}
program q178808;

uses stack;

type
	p_bracket_pair = ^t_bracket_pair;
	t_bracket_pair = record
		next: p_bracket_pair;
		left, right: char;		{ левая и правая скобки }
	end;

var
	pBrackets: p_bracket_pair;	{ указатель на список пар скобок }

{ добавление скобок в список с контролем }
procedure addBrackets( left, right: char );
var p: p_bracket_pair;
begin
	if (left <> ' ') and (right <> ' ') and (left <> right) then begin
		{ проверяем, есть ли уже такие символы в списке }
		p := pBrackets;
		while p <> nil do begin
			if (left = p^.left) or (left = p^.right) or
			   (right = p^.left) or (right = p^.right)
			then
				exit;	{ один из символов уже встречался }

			p := p^.next;
		end;

		{ вставляем новую пару скобок в список }
		new( p );
		p^.next := pBrackets;
		p^.left := left;
		p^.right := right;
		pBrackets := p;
	end;
end;

{ уничтожение списка скобок }
procedure freeBrackets;
var next: p_bracket_pair;
begin
	while pBrackets <> nil do begin
		next := pBrackets^.next;
		dispose( pBrackets );
		pBrackets := next;
	end;
end;

{ ищем символ в списке скобок
  возвращает указатель на пару, к которой относится скобка
  или nil, если символ не является скобкой
}
function findBracketPair( ch: char ): p_bracket_pair;
var p: p_bracket_pair;
begin
	p := pBrackets;
	while p <> nil do begin
		with p^ do
		if (ch = left) or (ch = right) then begin
			findBracketPair := p;
			exit;
		end;

		p := p^.next;
	end;
	findBracketPair := nil;
end;

{ читаем скобки из файла
  в каждой строке файла должно быть не меньше двух символов
  первые 2 символа - правая и левая скобки
  например:
()
[]
}
procedure readBrackets;
var f: text;
	s: string;
begin
	assign( f, 'brackets' );
	reset( f );
	while not eof(f) do begin
		readln( f, s );
		if length(s) >= 2 then
			addBrackets( s[1], s[2] );
	end;
	close(f);
end;

{ функция читает первую строку из файла и возвращает ее }
function readExpression : string;
var f: text;
	s: string;
begin
	assign( f, 'expr' );
	reset( f );
	readln( f, s );
	readExpression := s;
	close(f);
end;

{ ------------------------------------------------------------- }
const
	errIllegalChar   = 1;	{ коды ошибок }
	errNotPair       = 2;
	errUnexpectedEnd = 3;
	maxError         = 3;

	{ сообщения }
	msg : array[0..maxError] of string[30] =
(
	'Correct expression',
	'Illegal character',
	'Not a pair',
	'Unexpected end of expression'
);
{ ------------------------------------------------------------- }

var
	level : integer;	{ уровень вложенности }

{ показывает очередную скобку со сдвигом по уровню вложенности
  dir = 1  - левая скобка (PUSH)
  dir = -1 - правая скобка (POP)
}
procedure show( dir: integer; ch: char );
var i : integer;
begin
	if dir > 0 then
		inc( level );
	for i := level downto 1 do
		write( '  ' );
	writeln( ch );
	if dir < 0 then
		dec( level );
end;

{ разбор строки как скобочного выражения
  возвращает код ошибки, 0 - корректное выражение
}
function parse( s: string ): integer;
var i    : integer;	{ индексация символов в строке }
	ch   : char;	{ текуций символ }
	stack: TStack;	{ стек скобок }
	p    : p_bracket_pair;
begin
	stack.init;	{ инициализируем стек }
	level := 0; { начальный уровень }
	for i := 1 to length(s) do begin
		ch := s[i];
		if ch <> ' ' then begin
			p := findBracketPair( ch );	{ ищем символ в списке скобок }
			if p = nil then begin		{ неверный символ }
				show( 0, ch );			{ показываем символ для информации }
				parse := errIllegalChar;
				exit;
			end;
			if ch = p^.left then begin	{ левая скобка }
				show( 1, ch );			{ показываем }
				stack.push( p );		{ помещаем в стек }
			end
			else begin					{ правая скобка }
				show( -1, ch );			{ показываем }
				if p <> stack.pop then begin	{ непарная скобка, напр. (] }
					parse := errNotPair;
					exit;
				end;
			end;
		end;
	end;
	if stack.pop <> nil then	{ непустой стек - ошибка }
		parse := errUnexpectedEnd
	else
		parse := 0;
end;

var expr: string;		{ скобочное выражение }

BEGIN
	pBrackets := nil;
	readBrackets;		{ читаем скобки }
	if pBrackets <> nil then begin
		expr := readExpression;	{ читаем выражение }
		writeln( 'Parsing expression:' );
		writeln( expr );
		writeln( msg[parse( expr )] );	{ анализ и сообщение }
	end;
	freeBrackets;
END.

{ стек }
Unit Stack;

interface

type
	PStackItem = ^TStackItem;
	TStackItem = record
		next: PStackItem;	{ указатель на следующий элемент в стеке }
		data: pointer;		{ указатель на данные (или сами данные, }
	end;					{        если возможно приведение типа) }

	PTStack = ^TStack;
	TStack = object
		pTop: PStackItem;	{ указатель на вершину стека }

		constructor Init;	{ инициализация объекта }
		destructor Done; virtual;	{ освобождение памяти }

		procedure push( pData: pointer );	{ помещение объекта в стек }
		function pop: pointer;				{ извлечение объекта из стека }

		procedure clear; virtual;			{ очистка стека }
		procedure freeData( p: pointer ); virtual;	{ удаление данных }
	end;

implementation

{ инициализация объекта }
constructor TStack.Init;
begin
	pTop := nil;
end;

{ освобождение памяти }
destructor TStack.Done;
begin
	clear;
end;

{ помещение объекта в стек }
procedure TStack.push( pData: pointer );
var p: PStackItem;
begin
	new( p );
	p^.data := pData;
	p^.next := pTop;
	pTop := p;
end;

{ извлечение объекта из стека
  возвращает указатель на данные }
function TStack.pop: pointer;
var p: PStackItem;
begin
	if pTop <> nil then begin
		p := pTop;			{ сохраняем указатель на вершину }
		pop := p^.data;		{ возвращаем данные }
		pTop := p^.next;	{ новая вершина }
		dispose( p );		{ удаляем извлеченный элемент }
	end
	else
		pop := nil;
end;

{ очистка стека }
procedure TStack.clear;
var p: pointer;
begin
	while true do begin
		p := pop;
		if p = nil then exit;
		freeData( p );
	end;
end;

{ удаление данных, вызывается при очистке стека
  если нужно удалять данные, то производный объект должен
  перекрыть эту функцию
}
procedure TStack.freeData( p: pointer );
begin
end;

begin
end.

Var
...	f: text;

var
	pBrackets: p_bracket_pair;	{ указатель на список пар скобок }
	used_chars : set of char;	{ множество символов, используемых как скобки }

{ добавление скобок в список с контролем }
procedure addBrackets( left, right: char );
var p: p_bracket_pair;
begin
	if (left <> ' ') and (right <> ' ') and (left <> right) and
		{ проверяем, есть ли уже такие символы в списке }
		not (left in used_chars) and not (right in used_chars) then
	begin
		include( used_chars, left );
		include( used_chars, right );

		{ вставляем новую пару скобок в список }
		new( p );
		p^.next := pBrackets;
		p^.left := left;
		p^.right := right;
		pBrackets := p;
	end;
end;

{
Задано m пар не повторяющихся символов, воспринимаемых как скобочные
пары, т.е. если (a,b) - одна из пар, то a- левая скобка, b-
соответствующая правая скобка. Вводится текст, состоящий из любой
последовательности символов и пробела. Текст считается корректным,
если соблюдаются скобочные правила: за левой скобкой рано или поздно
следует соответствующая правая скобка. Предусмотреть произвольную
вложенность скобок. Надо определить корректность любого введенного
текста. И текст и пары скобок считать из входных файлов. В программе
использовать стек.
}
program q178808;

uses crt, stack;

type
	p_bracket_pair = ^t_bracket_pair;
	t_bracket_pair = record
		next: p_bracket_pair;
		left, right: char;		{ левая и правая скобки }
		attr: byte;				{ цвет для вывода на экран }
	end;

	t_attr_array = array[1..255] of byte;

const	{ предопределенные атрибуты }
	attr : array[0..5] of byte = ( 15, 14, 13, 11, 10, 9 );

var
	pBrackets: p_bracket_pair;	{ указатель на список пар скобок }
	used_chars : set of char;	{ множество символов, используемых как скобки }
	nextAttr : integer;			{ индекс атрибутов для следующей пары скобок }

{ добавление скобок в список с контролем }
procedure addBrackets( left, right: char );
var p: p_bracket_pair;
begin
	if (left <> ' ') and (right <> ' ') and (left <> right) and
		{ проверяем, есть ли уже такие символы в списке }
		not (left in used_chars) and not (right in used_chars) then
	begin
		include( used_chars, left );
		include( used_chars, right );

		{ вставляем новую пару скобок в список }
		new( p );
		p^.next := pBrackets;
		p^.left := left;
		p^.right := right;
		p^.attr := attr[nextAttr mod sizeof(attr)] or		{ цвет текста }
					( (nextAttr div sizeof(attr)) shl 4 );	{ цвет фона }
		pBrackets := p;
		inc( nextAttr );
	end;
end;

{ уничтожение списка скобок }
procedure freeBrackets;
var next: p_bracket_pair;
begin
	while pBrackets <> nil do begin
		next := pBrackets^.next;
		dispose( pBrackets );
		pBrackets := next;
	end;
end;

{ ищем символ в списке скобок
  возвращает указатель на пару, к которой относится скобка
  или nil, если символ не является скобкой
}
function findBracketPair( ch: char ): p_bracket_pair;
var p: p_bracket_pair;
	i: integer;
begin
	i := 0;
	p := pBrackets;
	while p <> nil do begin
		with p^ do
		if (ch = left) or (ch = right) then begin
			findBracketPair := p;
			exit;
		end;
		inc( i );
		p := p^.next;
	end;
	findBracketPair := nil;
end;

{ читаем скобки из файла
  в каждой строке файла должно быть не меньше двух символов
  первые 2 символа - правая и левая скобки
  например:
()
[]
}
procedure readBrackets;
var f: text;
	s: string;
begin
	assign( f, 'brackets' );
	reset( f );
	while not eof(f) do begin
		readln( f, s );
		if length(s) >= 2 then
			addBrackets( s[1], s[2] );
	end;
	close(f);
end;

{ функция читает первую строку из файла и возвращает ее }
function readExpression : string;
var f: text;
	s: string;
begin
	assign( f, 'expr' );
	reset( f );
	readln( f, s );
	readExpression := s;
	close(f);
end;

{ ------------------------------------------------------------- }
const
	errIllegalChar   = 1;	{ коды ошибок }
	errNotPair       = 2;
	errUnexpectedEnd = 3;
	maxError         = 3;

	{ сообщения }
	msg : array[0..maxError] of string[30] =
(
	'Correct expression',
	'Illegal character',
	'Not a pair',
	'Unexpected end of expression'
);
{ ------------------------------------------------------------- }

var
	level : integer;	{ уровень вложенности }

{ показывает очередную скобку со сдвигом по уровню вложенности
  dir = 1  - левая скобка (PUSH)
  dir = -1 - правая скобка (POP)
}
procedure show( dir: integer; ch: char; attr: byte );
var i : integer;
begin
	if dir > 0 then
		inc( level );
	for i := level downto 1 do
		write( '  ' );
	TextAttr := attr;
	writeln( ch );
	if dir < 0 then
		dec( level );
end;

{ разбор строки как скобочного выражения
  возвращает код ошибки, 0 - корректное выражение
  заполняет массив eattr цветовыми атрибутами для вывода результата
}
function parse( s: string; var eattr: t_attr_array ): integer;
var i    : integer;	{ индексация символов в строке }
	ch   : char;	{ текуций символ }
	stack: TStack;	{ стек скобок }
	p    : p_bracket_pair;
begin
	stack.init;	{ инициализируем стек }
	level := 0; { начальный уровень }
	for i := 1 to length(s) do begin
		ch := s[i];
		if ch <> ' ' then begin
			p := findBracketPair( ch );	{ ищем символ в списке скобок }
			if p = nil then begin		{ неверный символ }
				eattr[i] := 12;
				show( 0, ch, 12 );		{ показываем символ для информации }
				parse := errIllegalChar;
				exit;
			end;
			eattr[i] := p^.attr;		{ атрибут для отображения }
			if ch = p^.left then begin	{ левая скобка }
				show( 1, ch, p^.attr );	{ показываем }
				stack.push( p );		{ помещаем в стек }
			end
			else begin					{ правая скобка }
				show( -1, ch, p^.attr );	{ показываем }
				if p <> stack.pop then begin	{ непарная скобка, напр. (] }
					eattr[i] := 12;		{ заменяем на ярко-красный }
					parse := errNotPair;
					exit;
				end;
			end;
		end;
	end;
	if stack.pop <> nil then	{ непустой стек - ошибка }
		parse := errUnexpectedEnd
	else
		parse := 0;
end;

{ вывод результата с выделением цветом }
procedure coloredResult( var expr: string; var eattr: t_attr_array );
var i : integer;
begin
	for i := 1 to length(expr) do begin
		TextAttr := eattr[i];
		write( expr[i] );
	end;
	writeln;
end;

var expr: string;		{ скобочное выражение }
	eattr: t_attr_array; { атрибуты для каждого символа expr }
	iResult : integer;

BEGIN
	nextAttr := 0;
	pBrackets := nil;	{ никакие скобки пока не заданы }
	used_chars := [];
	{ атрибут по умолчанию - светло-серый на черном }
	fillchar( eattr, sizeof(eattr), 7 );

	readBrackets;		{ читаем скобки }
	if pBrackets <> nil then begin
		expr := readExpression;	{ читаем выражение }
		writeln( 'Parsing expression:' );
		writeln( expr );
		iResult := parse( expr, eattr );
		if iResult = 0 then
			TextAttr := 10	{ ярко-зеленый }
		else
			TextAttr := 12;	{ ярко-красный }

		writeln( msg[iResult] );	{ анализ и сообщение }
		coloredResult( expr, eattr );
		freeBrackets;
	end;
END.