Реализация сортировки стекаВ приведенной ниже программе содержимое стека
mainStack переносится в отсортированном виде в
resStack с использованием дополнительного стека
tmpStack):
Исходный код
Const maxStack = 100;
Type
TType = Integer;
TStack = Record
stArr: Array[1 .. maxStack] Of TType;
currTop: Integer;
End;
Procedure Init(Var s: TStack);
Begin
s.currTop := 0
End;
Procedure Push(Var s: TStack; x: TType);
Begin
If s.currTop <> maxStack Then
Begin
Inc(s.currTop); s.stArr[s.currTop] := x;
End;
End;
Function Pop(Var s: TStack): TType;
Begin
If s.currTop <> 0 Then
Begin
Pop := s.stArr[s.currTop]; Dec(s.currTop);
End;
End;
Function Top(Var s: TStack): TType;
Begin
Top := s.stArr[s.currTop];
End;
Function IsEmpty(Var s: TStack): Boolean;
Begin
IsEmpty := (s.currTop = 0)
End;
Procedure Print(Var s: TStack);
Var i: Integer;
Begin
For i := 1 To s.currTop Do
Write(s.stArr[i]:4);
WriteLn
End;
Const
n = 10;
arr: Array[1 .. n] Of TType =
(1, 2, 4, 5, 2, 6, 7, 0, 9, 2);
Var
mainStack, resStack, tmpStack: TStack;
i: integer;
begin
Init(mainStack);
Init(resStack);
Init(tmpStack);
For i := 1 To n Do
Push(mainStack, arr[i]);
Print(mainStack);
While not IsEmpty(mainStack) Do
Begin
If IsEmpty(resStack) or (Top(resStack) < Top(mainStack))
Then Push(resStack, Pop(mainStack))
Else
Begin
While (Top(resStack) > Top(mainStack)) and
(not IsEmpty(resStack)) Do
Push(tmpStack, Pop(resStack));
Push(resStack, Pop(mainStack));
While not IsEmpty(tmpStack) Do
Push(resStack, Pop(tmpStack))
End
End;
Print(resStack)
end.
В присоединенном файле - программа сортировки стека
s_stack.pas ( 1.65 килобайт )
Кол-во скачиваний: 2173Реализация сортировки очередиВ примере реализуется сортировка очереди (реализованной в виде объекта) без применения дополнительных очередей.
Исходный код
type
ttype = integer;
ptitem = ^titem;
titem = record
data: ttype;
next: ptitem;
end;
tqueue = object
head, tail: ptitem;
constructor init;
destructor done;
procedure put(x: ttype);
function get: ttype;
function empty: boolean;
procedure print;
function get_count: word;
end;
constructor tqueue.init;
begin
head := nil; tail := nil;
end;
destructor tqueue.done;
begin
while empty do get
end;
procedure tqueue.put(x: ttype);
var p: ptitem;
begin
new(p);
p^.data := x; p^.next := nil;
if empty then head := p
else tail^.next := p;
tail := p
end;
function tqueue.get: ttype;
var p: ptitem;
begin
if not empty then
begin
p := head;
head := head^.next;
get := p^.data;
dispose(p);
end
else
begin
writeln('reading from empty queue');
halt(102)
end;
end;
function tqueue.empty: boolean;
begin
empty := not assigned(head)
end;
procedure tqueue.print;
var p: ptitem;
begin
p := head;
write('(queue) <');
while assigned(p) do
begin
write(p^.data, ' ');
p := p^.next
end;
writeln('>')
end;
function tqueue.get_count: word;
var
count: word;
p: ptitem;
begin
p := head; count := 0;
while assigned(p) do
begin
inc(count);
p := p^.next
end;
get_count := count
end;
{ А вот и сама сортировка очереди }
procedure sort(var q: tqueue);
var
i, j, k,
it, it_next: integer;
len: word;
begin
len := q.get_count;
for i := 1 to len do begin
it := q.get;
for j := 1 to len - i do begin
it_next := q.get;
if it > it_next then begin
q.put(it); it := it_next;
end
else
q.put(it_next)
end;
for k := 1 to pred(i) do
q.put(q.get);
q.put(it);
end;
end;
const
test: array[1 .. 10] of integer =
(2, 5, 17, 7, 9, 3, 4, 6, 11, 71);
var
i: integer;
qint: tqueue;
begin
qint.init;
for i := 1 to 10 do
qint.put(test[i]);
qint.print;
sort(qint);
qint.print;
qint.done;
end.