Динамические структуры данных

program Project1;
 
type
  {Тип сновных данных.}
  TData = Integer;
 
  {Тип указателя на элемент стека.}
  TPStElem = ^TStElem;
  {Тип элемента стека.}
  TStElem = record
    Data : TData;
    PNext : TPStElem; {Указатель на следующий элемент.}
  end;
  {Отдельный тип, описывающий стек, заводить не будем.
  Для этого достаточно типа TPStElem.}
 
  {Тип указателя на элемент дека.}
  TPDeckElem = ^TDeckElem;
  {Тип элемента дека.}
  TDeckElem = record
    Data : TData;
    PNext, PPrev : TPDeckElem; {Указатели на следующий и предыдущий элементы.}
  end;
  {Тип, описывающий дек.}
  TDeck = record
    PFirst, PLast : TPDeckElem; {Указатели на первый и последний элементы.}
  end;
 
{------------------------------}
{Стек.}
{------------------------------}
 
{Добавление элемента на вершину стека.}
procedure Push(var aPStack : TPStElem; const aData : TData);
var
  PElem : TPStElem;
begin
  New(PElem);
  PElem^.Data := aData;
  PElem^.PNext := aPStack;
  aPStack := PElem;
end;
 
{Изъятие элемента с вершины стека.
Если стек не пуст, то с вершины стека изымается элемент и его значение
(основные данные) возвращается через параметр aData. В этом случае, функция
возвращает значение True. Если стек пуст, то операция отменяется, а функция
возвращает значение False.}
function Pop(var aPStack : TPStElem; var aData : TData) : Boolean;
var
  PElem : TPStElem;
begin
  Pop := False;
  if aPStack = nil then Exit;
 
  PElem := aPStack;
  aPStack := PElem^.PNext;
  aData := PElem^.Data;
  Dispose(PElem);
  Pop := True;
end;
 
{Освобождение памяти, занятой стеком (очистка стека).}
procedure StackFree(var aPStack : TPStElem);
var
  Data : TData;
begin
  while Pop(aPStack, Data) do;
end;
 
{Распечатка элементов стека в направлении вершина - дно.}
procedure WritelnStack(const aPStack : TPStElem);
var
  PElem : TPStElem;
  i : Integer;
begin
  if aPStack = nil then begin
    Writeln('Стек пуст.');
    Exit;
  end;
 
  PElem := aPStack;
  i := 0;
  while PElem <> nil do begin
    Inc(i);
    if i > 1 then Write(', ');
    Write(PElem^.Data);
    PElem := PElem^.PNext;
  end;
  Writeln;
end;
 
{------------------------------}
{Дек.}
{------------------------------}
 
{Процедура инициализация дека. Внимание! Эту процедуру можно выполнять только
в отношении пустого дека. Иначе будут утечки памяти.}
procedure DeckInit(var aDeck : TDeck);
begin
  aDeck.PFirst := nil;
  aDeck.PLast := nil;
end;
 
{Добавление элемента в начало дека.}
procedure PushF(var aDeck : TDeck; const aData : TData);
var
  PElem : TPDeckElem;
begin
  New(PElem);
  PElem^.Data := aData;
  PElem^.PPrev := nil;
  PElem^.PNext := aDeck.PFirst;
  if aDeck.PFirst <> nil then
    aDeck.PFirst^.PPrev := PElem;
  aDeck.PFirst := PElem;
  if aDeck.PLast = nil then
    aDeck.PLast := PElem;
end;
 
{Добавление элемента в конец дека.}
procedure PushL(var aDeck : TDeck; const aData : TData);
var
  PElem : TPDeckElem;
begin
  New(PElem);
  PElem^.Data := aData;
  PElem^.PNext := nil;
  PElem^.PPrev := aDeck.PLast;
  if aDeck.PLast <> nil then
    aDeck.PLast^.PNext := PElem;
  aDeck.PLast := PElem;
  if aDeck.PFirst = nil then
    aDeck.PFirst := PElem;
end;
 
{Изъятие элемента из начала дека.
Если дек не пуст, то из начала дека изымается элемент и его значение
(основные данные) возвращается через параметр aData. В этом случае, функция
возвращает значение True. Если дек пуст, то операция отменяется, а функция
возвращает значение False.}
function PopF(var aDeck : TDeck; var aData : TData) : Boolean;
var
  PElem : TPDeckElem;
begin
  PopF := False;
  if aDeck.PFirst = nil then Exit;
 
  PElem := aDeck.PFirst;
  aDeck.PFirst := PElem^.PNext;
  if aDeck.PFirst <> nil then
    aDeck.PFirst^.PPrev := nil;
  if aDeck.PLast = PElem then
    aDeck.PLast := nil;
  aData := PElem^.Data;
  Dispose(PElem);
  PopF := True;
end;
 
{Изъятие элемента из конца дека.
Если дек не пуст, то из конца дека изымается элемент и его значение
(основные данные) возвращается через параметр aData. В этом случае, функция
возвращает значение True. Если дек пуст, то операция отменяется, а функция
возвращает значение False.}
function PopL(var aDeck : TDeck; var aData : TData) : Boolean;
var
  PElem : TPDeckElem;
begin
  PopL := False;
  if aDeck.PFirst = nil then Exit;
 
  PElem := aDeck.PLast;
  aDeck.PLast := PElem^.PPrev;
  if aDeck.PLast <> nil then
    aDeck.PLast^.PNext := nil;
  if aDeck.PFirst = PElem then
    aDeck.PFirst := nil;
  aData := PElem^.Data;
  Dispose(PElem);
  PopL := True;
end;
 
{Освобождение памяти, занятой деком (очистка дека).}
procedure DeckFree(var aDeck : TDeck);
var
  Data : TData;
begin
  while PopF(aDeck, Data) do;
end;
 
{Распечатка дека в направлении начало - конец.}
procedure WritelnDeck(const aDeck : TDeck);
var
  PElem : TPDeckElem;
  i : Integer;
begin
  if aDeck.PFirst = nil then begin
    Writeln('Дек пуст.');
    Exit;
  end;
 
  PElem := aDeck.PFirst;
  i := 0;
  while PElem <> nil do begin
    Inc(i);
    if i > 1 then Write(', ');
    Write(PElem^.Data);
    PElem := PElem^.PNext;
  end;
  Writeln;
end;
 
const
  {Основа для установки размера стека.}
  M = 10;
var
  PSt : TPStElem;
  Deck : TDeck;
  Data : TData;
  i : Integer;
  S : String;
begin
  repeat
    Writeln('------------------------------');
    {Начальная инициализация стека и дека.}
    PSt := nil;
    DeckInit(Deck);
 
    {Записываем в стек случайные числа.}
    Randomize;
    for i := 1 to 5 + Random(M) do
      Push(PSt, Random(11) - 5); {-5..5}
    
    {Распечатка стека и дека.}
    Writeln('Начальное состояние.');
    Writeln('Стек (вершина - дно):');
    WritelnStack(PSt);
    Writeln('Дек (начало - конец):');
    WritelnDeck(Deck);
 
    {Решение задачи.}
    while Pop(PSt, Data) do
      if Data mod 2 <> 0 then
        PushF(Deck, Data * Data)
      else
        PushL(Deck, Abs(Data));
    
    {Распечатка стека и дека.}
    Writeln;
    Writeln('После обработки.');
    Writeln('Стек (вершина - дно):');
    WritelnStack(PSt);
    Writeln('Дек (начало - конец):');
    WritelnDeck(Deck);
 
    {Освобождение памяти, занятой стеком и деком.}
    StackFree(PSt);
    DeckFree(Deck);
    Writeln;
    Writeln('Память, занятая под стек и дек, освобождена.');
 
    Writeln('Повторить - Enter. Выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.