QBHEAP - Hàng đợi có độ ưu tiên

Tác giả: ll931110

Ngôn ngữ: Pascal

Program QBHEAP;
        Const
                input  = '';
                output = '';
        Var
                heap,a: array[0..15000] of longint;
                 nHeap: integer;

Procedure update(v: longint);
          Var
                parent,child: integer;
          Begin
                inc(nHeap);
                heap[nHeap]:= v;

                child:= nHeap;
                parent:= child div 2;

                While (parent > 0) and (heap[parent] < v) do
                      Begin
                                heap[child]:= heap[parent];
                                child:= parent;
                                parent:= child div 2;
                      End;

                heap[child]:= v;
          End;

Function get: longint;
         Begin
                get:= heap[1];
         End;

Procedure pop;
          Var
                r,c,v,t: longint;
          Begin
                heap[1]:= heap[nHeap];
                dec(nHeap);

                r:= 1;
                v:= heap[r];

                While r * 2 <= nHeap do
                      Begin
                        c:= r * 2;
                        If (c < nHeap) and (heap[c + 1] > heap[c]) then inc(c);

                        If v >= heap[c] then break;
                        heap[r]:= heap[c];
                        r:= c;
                      End;

                heap[r]:= v;
          End;

Procedure solve;
          Var
                f: text;
                v: longint;
               ch: char;
          Begin
                nHeap:= 0;

                Assign(f, input);
                        Reset(f);

                While not eof(f) do
                      Begin
                                Read(f, ch);
                                If ch = '+' then
                                        Begin
                                                Readln(f, v);
                                                If nHeap < 15000 then update(v);
                                        End
                           else if ch = '-' then
                                        Begin
                                                v:= get;
                                                While (v = get) and (nHeap > 0) do pop;
                                                Readln(f);
                                        End;
                      End;

                Close(f);
          End;

Procedure heapsort;
          Var
                    f: text;
                i,num: integer;
          Begin
                Assign(f, output);
                        Rewrite(f);

                num:= 0;
                a[0]:= -1;

                For i:= nHeap downto 1 do
                        Begin
                                If a[num] <> get then
                                        Begin
                                                inc(num);
                                                a[num]:= get;
                                        End;
                                pop;
                        End;

                Writeln(f, num);
                For i:= 1 to num do writeln(f, a[i]);

                Close(f);
          End;

Begin
        solve;
        heapsort;
End.

Download