Основная прога
program sorting;
uses def24;
var c : char;
s : stack;
t : telem;
procedure Concat(var s1 : stack;s2:stack);
var s3:stack;
begin
init(s3);
while not empty(s2) do begin
put(s3,top(s2));get(s2);
end;
while not empty(s3) do begin
put(s1,top(s3));
get(s3)
end;
end; { Concat }
procedure QuickSort(var s : stack);
var s1,s2 : stack;V,k:telem;
begin
if not empty(s) then begin
init(s1);init(s2);
V:=top(s);get(s);
while not empty(s) do begin
k:=top(s);
if k.key< V.key then put(s1,k)
else put(s2,k);
get(s);
end;
QuickSort(s1);
QuickSort(s2);
put(s1,V);
Concat(s1,s2);
s:=s1;
end;
end; { QuickSort }
Begin
init(s);
repeat
writeln('1=Init 2=Empty 3=Get 4=Top 5=Put 6=Print 7=Kolvo 8=Sort 9=Exit');
readln©; case c of
'1' : init(s);
'2' : writeln(empty(s));
'3' : if not empty(s) then get(s)
else writeln('Stack is empty!');
'4' : if not empty(s) then begin
t:=top(s);
writeln('Key: ',t.key:1,'. Data: ',t.data,'.');
end
else writeln('Stack is empty!');
'5' : begin
writeln('Input key:'); readln(t.key);
writeln('Input data:'); readln(t.data);
put(s,t);
end;
'6' : if not empty(s) then print(s)
else writeln('Stack is empty!');
'7' : writeln('Number of elements: ',kolvo(s):1);
'8' : if empty(s) then writeln('Stack is empty!')
else if kolvo(s)>1 then QuickSort(s);
end;
until c='9';
end.
Модуль
unit def24;
interface
const l = 30;
type colors = (red,yellow,green,black);
type
telem = record
key : integer;
data : colors ;
end;
stack = record m : array[1..l] of telem;
hill : integer
end;
procedure init(var s:stack);
function empty(var s:stack):boolean;
function top(var s:stack):telem;
procedure get(var s:stack);
procedure print(var s:stack);
function kolvo(var s:stack):integer;
procedure put(var s:stack; t:telem);
implementation
procedure init(var s:stack);
begin
s.hill:=0
end;
function empty(var s:stack):boolean;
begin
empty:=(s.hill=0)
end;
function top(var s:stack):telem;
begin
top:=s.m[s.hill]
end;
procedure get(var s:stack);
begin
s.hill:=s.hill-1;
end;
procedure print(var s:stack);
var i:integer;
begin
for i:=s.hill downto 1 do
writeln('Key: ',s.m[i].key:2,'. Data: ',s.m[i].data,'.')
end;
function kolvo(var s:stack):integer;
begin
kolvo:=s.hill
end;
procedure put(var s:stack; t:telem);
begin
if s.hill<l then begin s.hill:=s.hill+1; s.m[s.hill]:=t end
else writeln('Stack is full!')
end; { put }
end.