Описать процедуру, которая из одного стека строит два

program Project1;
 
{Задача:
Описать процедуру, которая из одного стека строит два новых - один из
положительных элементов, другой - из остальных.}
 
type
  {Основные данные элемента стека.}
  TData = Integer;
  {Указатель на элемент стека.}
  TPElem = ^TElem;
  {Элемент стека.}
  TElem = record
    Data : TData;   {Основные данные.}
    PNext : TPElem; {Указатель на следующий элемент стека.}
  end;
  {Для стека отдельный тип можно не создавать. Стек будет представлен в виде
  указателя на элемент, расположенный на вершине стека. Поэтому, переменная
  представляющая стек, будет иметь тип TPElem.}
 
{Добавление элемента на вершину стека.}
procedure Push(var aPSt : TPElem; const aData : TData);
var
  PElem : TPElem;
begin
  New(PElem);
  PElem^.Data := aData;
  PElem^.PNext := aPSt;
  aPSt := PElem;
end;
 
{Изъятие элемента с вершины стека.
Если стек не пуст, то с вершины стека изымается элемент и его значение
(основные данные) возвращается через параметр aData. В этом случае, функция
возвращает значение True. Если стек пуст, то операция отменяется, а функция
возвращает значение False.}
function Pop(var aPSt : TPElem; var aData : TData) : Boolean;
var
  PElem : TPElem;
begin
  Result := False;
  if aPSt <> nil then
  begin
    PElem := aPSt;
    aPSt := PElem^.PNext;
    aData := PElem^.Data;
    Dispose(PElem);
    Result := True;
  end;
end;
 
{Распечатка элементов стека в направлении вершина - дно.
Здесь мы будем работать со структурой не как со стеком, а как со списком.}
procedure StWriteln(const aPSt : TPElem);
var
  P : TPElem;
begin
  P := aPSt;
  if P = nil then
    Write('Стек пуст.')
  else
  repeat
    if P <> aPSt then {Если этот элемент не в начале списка, то ставим перед ним запятую.}
      Write(', ');
    Write(P^.Data); {Распечатываем основные данные элемента.}
    P := P^.PNext;  {Получаем указатель на следующий элемент списка.}
  until P = nil;    {Если достигли конца списка, то перебор закончен.}
  Writeln;
end;
 
{Освобождение памяти, выделенной для элементов стека (очистка стека).}
procedure StFree(var aPSt : TPElem);
var
  Data : TData;
begin
  while Pop(aPSt, Data) do;
end;
 
{Процедура, которая из стека aPSt1 переливает положительные элементы - в стек aPSt2,
а все остальные элементы - в стек aPSt3.}
procedure StSplit(var aPSt1 : TPElem; var aPSt2, aPSt3 : TPElem);
var
  Data : TData;
begin
  {Очистка принимающих стеков.}
  StFree(aPSt2);
  StFree(aPSt3);
  {Извлекаем элементы с вершины первого стека и кладём их на вершины второго
  и третьего стеков в зависимости от значений выбранных элементов.
  При этом во втором и третьем стеках элементы окажутся в обратном порядке
  относительно порядка, в котором они располагались в первом стеке.}
  while Pop(aPSt1, Data) do
    if Data > 0 then
      Push(aPSt2, Data)
    else
      Push(aPSt3, Data);
end;
 
const
  M = 15; {Такое количество элементов мы запишем в первый стек.}
var
  PSt1, PSt2, PSt3 : TPElem;
  i : Integer;
  S : String;
begin
  {Начальная инициализация стеков.}
  PSt1 := nil;
  PSt2 := nil;
  PSt3 := nil;
 
  repeat
    {Записываем случайные элементы в первый стек.}
    Randomize;
    for i := 1 to M do
      Push(PSt1, Random(11) - 5); {Целые числа из диапазона -5..5.}
 
    {Распечатка стеков.}
    Writeln('Начальное состояние стеков.');
    Writeln('Первый стек (вершина - дно):');
    StWriteln(PSt1);
    Writeln('Второй стек (вершина - дно):');
    StWriteln(PSt2);
    Writeln('Третий стек (вершина - дно):');
    StWriteln(PSt3);
 
    {Переливаем элементы из первого стека: положительные - во второй стек,
    все остальные - в третий стек.}
    StSplit(PSt1, PSt2, PSt3);
 
    {Распечатка стеков.}
    Writeln('Состояние стеков после переливания.');
    Writeln('Первый стек (вершина - дно):');
    StWriteln(PSt1);
    Writeln('Второй стек (вершина - дно):');
    StWriteln(PSt2);
    Writeln('Третий стек (вершина - дно):');
    StWriteln(PSt3);
 
    {Освобождение памяти, выделенной для стеков.}
    StFree(PSt1);
    StFree(PSt2);
    StFree(PSt3);
    Writeln('Память, выделенная для стеков, освобождена.');
 
    Writeln('Повторить - Enter. Выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.