-- Package:  Binary_Heap_Pack declerations
-- by George North
-- Fall 1994
-- 

-- Problem:  provied a generic Binary Heap

-- ======================================================================

generic
   type Element_Type is private;
   with function ">" ( Left, Right : Element_Type ) return boolean;
   with procedure put( Element : Element_Type );
   Min_Element : Element_Type;

-- ======================================================================

package Binary_Heap_Pack is

   type Array_of_Element_Type is array(natural range <>) 
                              of Element_Type;
   type Priority_Queue(  Max_Size: positive) is limited private;

-- ======================================================================

   -- Procedure:     Make_Null
   -- Precondition:  none
   -- Postcondition: empty Binary Heap

   procedure Make_Null(  H   : out    Priority_Queue );

-- ======================================================================

   -- Procedure:     Insert
   -- Precondition:  valid Binary Heap
   -- Postcondition: new Element in heap, or error Heap Overflow

   procedure Insert(     X   :        Element_Type; 
                         H   : in out Priority_Queue );

-- ======================================================================

   -- Procedure:     Delete_Min
   -- Precondition:  valid Binary Heap
   -- Postcondition: remove Top and return element, or Heap Underflow

   procedure Delete_Min( Min : out    Element_Type; 
                         H   : in out Priority_Queue );

-- ======================================================================

   -- Function:      Find_Min
   -- Precondition:  valid Binary Heap
   -- Postcondition: return smallest element, or Heap Underflow

   function Find_Min(    H   : Priority_Queue ) return Element_Type;

-- ======================================================================

   -- Function:      Is_Empty
   -- Precondition:  valid Binary Heap
   -- Postcondition: none

   function Is_Empty(    H   : Priority_Queue ) return boolean;

-- ======================================================================

   -- Function:      Is_Full
   -- Precondition:  valid Binary Heap
   -- Postcondition: none

   function Is_Full(     H   : Priority_Queue ) return boolean;

-- ======================================================================

   -- Procedure:     Build_Heap
   -- Precondition:  valid Array of elements
   -- Postcondition: new Binary Heap

   procedure Build_Heap( Num : in     natural; -- # of elements for heap                      
                    Raw_Data : in     Array_of_Element_Type; -- raw data
                         H   : out    Priority_Queue);

-- ======================================================================

   -- Procedure:     Print Heap  --  to check correctness of Heap
   -- Precondition:  valid Binary Heap
   -- Postcondition: none

   procedure Print_Heap( H   : in     Priority_Queue);

-- ======================================================================

   Overflow  : exception;
   Underflow : exception;

-- ======================================================================

private
   type Priority_Queue(Max_Size : positive) is
       record 
           Size        :       natural :=0;
           Elements    :       Array_of_Element_Type( 0..Max_Size );
       end record;

-- ======================================================================

end Binary_Heap_Pack;

-- ======================================================================
-- ======================================================================


-- Package Body:  Binary_Heap_Pack

-- ======================================================================

with Text_IO; use Text_IO;

-- ======================================================================

package body Binary_Heap_Pack is

-- ======================================================================

   procedure Make_Null(  H   : out    Priority_Queue ) is

   begin  -- Make_Null
      H.Size          := 0;
      H.Elements( 0 ) := Min_Element;
   end Make_Null;

-- ======================================================================

   procedure Insert(     X   :        Element_Type; 
                         H   : in out Priority_Queue ) is

      I : Natural;

   begin  -- Insert
      if Is_Full( H ) then
         raise Overflow;
      end if;

      -- maka a hole
      H.Size := H.Size + 1;
      I      := H.Size;

      -- bubble up
      while H.Elements( I/2 ) > X loop
      -- Invariant : The top 1st element of Heap is always the smallest
      --             element.  The 0th element of Heap is a Sentinal 
      --             containing a value small that the Heap's smallest
      --             value.  Each itteration of loop moves up through
      --             the elements and loop will terminate when X is
      --             smaller than current element or when top of Heap
      --             is reached. 
         H.Elements( I ) := H.Elements( I/2 );
         I              := I/2;
      end loop;
      -- Asseration: new element placed above elements of lower value

      -- store new element
      H.Elements( I ) := X;
   end Insert;

-- ======================================================================

   procedure Delete_Min( Min : out    Element_Type; 
                         H   : in out Priority_Queue ) is

      Child        : Integer      := 1;
      I            : Integer      := 1;
      Last_Element : Element_Type := H.Elements( H.Size );

   begin  -- Delete_Min
      if Is_Empty( H ) then
         raise Underflow;
      end if;
      
      Min    := H.Elements( 1 );
      H.Size := H.Size - 1;
      
      loop
      -- Inveriant: Heap contains a finite number of elements.  Starting
      --            with the last element in Heap, each pass thru loop
      --            results in moving pointer Child closer to
      --            top of Heap.  Loop will terminate when pointer Child
      --            reached top of Heap or when Last_Element is less then 
      --            or equal to current Child.
         -- find smaller child.
         Child := I * 2;
         exit when Child > H.Size;
         if                    Child /= H.Size 
         and then H.Elements( Child ) >  H.Elements( Child + 1 ) then
            Child := Child + 1;
         end if;
         
         -- push down one level if needed.
         exit when H.Elements( Child ) > Last_Element;
         H.Elements( I ) := H.Elements( Child );
         I              := Child;
      end loop;
      -- Asseration: Element at top of heap is deleted and returned to 
      --             caller.  Size of Heap is reduced by one.  Smallest
      --             remaining element is promoted to top of heap.
      
      H.Elements( I ) := Last_Element;
   end Delete_Min;

-- ======================================================================

   function Find_Min(    H   : Priority_Queue ) return Element_Type is

      anElem : Element_Type;

   begin -- Find_Min
      if Is_Empty( H ) then
         raise Underflow;
      end if;
      return H.Elements( 1 );
   end Find_Min;

-- ======================================================================

   function Is_Empty(    H   : Priority_Queue ) return boolean is

   begin -- Is_Empty
      return H.Size = 0;
   end Is_Empty;

-- ======================================================================

   function Is_Full(     H   : Priority_Queue ) return boolean is

   begin -- Is_Full
      return H.Size = H.Elements'Last;
   end Is_Full;

-- ======================================================================

   procedure Build_Heap( Num : in     natural; -- # of elements for heap                      
                    Raw_Data : in     Array_of_Element_Type; -- raw data
                           H :    out Priority_Queue) is

      A : Priority_Queue( Num );
      
      -- Procedure:     Perc_Down
      -- Precondition:  array of elements, pointer to an element
      -- Postcondition: element is reqositioned to be below elements
      --                of higher value.

      procedure Perc_Down( A : in out Priority_Queue;
                           I : in     natural        ) is
         
         Current_Node : natural      := I ;
         Tmp          : Element_Type := A.Elements( Current_Node );
         Child        : natural;

      begin -- Perc_Down
         loop
         -- Invariant: each loop iteration looks at the two child nodes
         --            of node to be pushed down ... loop terminates if
         --            node to be pushed is leaf node ... loop terminates
         --            if node to be pushed is less than both of the 
         --            leaves ... else bubble moves down to smallest leaf
            -- find a larger child if not at a leaf
            Child              := Current_Node * 2;
            exit when Child     > A.Elements'Last;
            if       Child /= A.Elements'Last
            and then A.Elements( Child ) > A.Elements( Child + 1 ) then
               Child := Child + 1;
            end if;
            -- push bubble down if needed
            exit when A.Elements( Child ) > Tmp;
            A.Elements( Current_Node )   := A.Elements( Child );
            Current_Node        := Child;
         end loop;
         -- Asseration: Current Node is pushed down is binary heap tree
         --             until it finds it correct level ... as a child to
         --             a larger parrent.
         A.Elements( Current_Node ) := Tmp;      
      end Perc_Down;
   
   begin  -- Build_Heap
      -- make a heap, copy raw data to it
      Make_Null( A );
      A.Elements( 1 .. Num ) := Raw_Data( 1 .. Num );
      A.Size                 := Num;
      -- Perculate Down larger size nodes
      for I in reverse 1 .. ( Num / 2 ) loop
         Perc_Down( A, I );
      end loop;
      -- finished
      H.Elements( 0 .. Num ) := A.Elements( 0 .. Num );
      H.Size                 := A.Size;
   end Build_Heap;

-- ======================================================================

   procedure Print_Heap( H   : in     Priority_Queue) is

      MaxNodes : natural := 1;
      Depth    : natural := 0;
      
      -- Procedure:     Print_a_Chile, recursive routine to print heap
      -- Precondigion:  valid heap, element I to print, offset D
      -- Postcondition: none
      
      procedure Print_a_Child( I : in     natural; 
                               D : in     natural ) is
         
         J : natural;
         
         begin
            -- right child index equals Node index * 2 + 1
            J := I * 2 + 1;
            -- is right child index greater than maximum # of nodes
            if J <= MaxNodes then
               Print_a_Child( J, D + 1 );
            end if;
            
            -- print head node if it exists
            if I <= H.Size then
               Set_Col( To => ( Positive_Count( ( (D) * 13 ) + 1) ) );
               put( H.Elements( I ) );
            end if;
            New_Line;
            
            -- left child index equals Node index * 2
            J := J -1;
            -- is right child index greater than maximum # of nodes
            if J <= MaxNodes then
               Print_a_Child( J, D + 1 );
            end if;
         end Print_a_Child;
         
   begin  -- Print_Heap
      
      if Is_Empty( H ) then
         raise Underflow;
      else
         -- calculate size and height of heap
         while MaxNodes <= H.Size loop
         -- Inveriant: each loop iteration increases MaxNodes untill 
         --            it exceeds size of this heap
            Depth    := Depth    + 1;
            MaxNodes := MaxNodes * 2;
         end loop;
         -- Asseration: maximum # of Nodes for Heap of this size
         --             and Depth of this Heap
         MaxNodes := MaxNodes - 1;
         -- print the heap
         Print_a_Child ( 1, 0 );
      end if;
         
   end Print_Heap;

-- ======================================================================

end Binary_Heap_Pack;

-- ======================================================================

	
Program: CPU Scheduler
a sample driver program for Binary_Heap_Pack




with   Text_IO; use Text_IO;
with   Text_IO; use Text_IO;
with My_Int_IO; use My_Int_IO;
with My_Flt_IO; use My_Flt_IO;
with Binary_Heap_Pack;

-- ======================================================================

-- Program: CPU Scheduler

-- Problem: Provide scheduling services such that the shortest job
--          has highest priority.

-- ======================================================================

procedure CPU_Scheduler is

   -- variable used to redirect console input (FOR TESTING ONLY)
   sampleData      : Text_IO.File_Type;

   -- define a record for CPU job information
   subtype ID_Type is natural range 0 .. natural'last;
   Time_Est_Min : constant Float := 0.0;
   Time_Est_Max : constant Float := 1000.0;
   subtype Time_Est_Type is Float range Time_Est_Min .. Time_Est_Max;
   type CPU_Job_Record is
      record
         ID       : ID_Type;
         Time_Est : Time_Est_Type;
      end record;
   
   -- variables and constants
   aCPU_Job                 : CPU_Job_Record;
   theEvent                 : Character;
   Beginning_of_Data_Mark   : constant character := '(';
   End_of_Data_Mark         : constant character := ')';
   
   -- instanciate a Binary Heap ADT from generic
   CPU_Job_Sentinal   : ID_Type  := 0;
   CPU_Min_Element    : CPU_Job_Record := (CPU_Job_Sentinal, 0.0 );
   function CPU_Job_Greater( A : in CPU_Job_Record;
                             B : in CPU_Job_Record ) return boolean;
   procedure Put_CPU_Job(    R : in CPU_Job_Record);
   package CPU_Job_ADT is 
        new Binary_Heap_Pack( Element_Type => CPU_Job_Record,
                                       ">" => CPU_Job_Greater,
                                       Put => Put_CPU_Job,
                              Min_Element  => CPU_Min_Element  );
   use CPU_Job_ADT;

   -- make one Binary Heap
   CPU_Job_Max           : constant natural := 300;
   CPU_Priority_Queue    : Priority_Queue ( CPU_Job_Max );
   subtype Data_Array_Type is Array_of_Element_Type( 0 .. CPU_Job_Max );
   Initial_Data_Array    : Data_Array_Type;
   Num_of_Array_Elements : natural;
   
   -- needed exceptions
   No_Valid_Input     : exception;
   Not_a_Number       : exception;

-- ======================================================================

   -- Function      : CPU_Job_Greater, used for ">" in generic package
   -- Precondition  : valid CPU_Job Records
   -- Postcondition : boolean, true if greater than

   function CPU_Job_Greater( A : in CPU_Job_Record;
                             B : in CPU_Job_Record ) return boolean is
   begin  -- CPU_Job_Greater
      return A.Time_Est > B.Time_Est;
   end CPU_Job_Greater;

-- ======================================================================

   -- Procedure     : Put_CPU_Job, used for "put" in generic package
   -- Precondition  : valid Flight Records
   -- Postcondition : none

   procedure Put_CPU_Job(    R : in CPU_Job_Record) is
   begin  -- Put_CPU_Job
      put( R.ID, 4 );
      put( " (" );
      put( R.Time_Est, 1, 3, 0 );
      put( ")" );
   end Put_CPU_Job;

-- ======================================================================

   -- Procedure     : Get_1_Line
   -- Precondition  : none
   -- Postcondition : none

   procedure Get_1_Line( Event    :    out Character;
                         aCPU_Job :    out CPU_Job_Record ) is
      
      Max_Chrs  : constant integer := 132;
      One_Line  : String ( 1 .. Max_Chrs );
      theEvent  : Character;
      anID      : ID_Type;
      aTime_Est : Time_Est_Type := 0.0;
      TE_frac   : Natural := 0;
      I, J, K, L: Natural := 0;
      aChar     : Character;
      
      -- Procedure:     Next_not_Blank, skip blanks in string
      -- Precondition:  valid array and array index
      -- Postcondition: position index to next non blank character

      procedure Next_not_Blank ( I : in out Natural ) is

         begin -- Next_not_Blank
            while One_Line( I + 1 ) = ' ' and I + 1 < L loop
            -- Inveriant: each loop itteration, I is increased by one
            --            loop terminates when I reaches end of line L
            --            or when a space character is reached
               I := I + 1;
            end loop;
            -- Asseration: I is set to point at the last space character
            --             before a non-space character
         end Next_not_Blank;
   
   begin -- Get_1_Line
      theEvent := ' ';
      -- input one line of data, a character at a time
      while not End_of_Line loop
      -- Inveriant: loop to input one line, one character at a time
         L := L + 1;
         get( One_Line( L ) );
         put( One_Line( L ) );
         if L > Max_Chrs then
            exit;
         end if;
      end loop;
      -- Asseration: Array of characters
      if not End_of_File then
         Skip_Line;
      end if;
      Next_not_Blank( I );
      K := I + 1;
      J := K;
      
      -- parce this line
      loop
      -- Inveriant: each loop iteration moves pointer I closer to end of 
      --            a string, loop terminates when 1). I reaches end of
      --            line, or 2). an beginning or end of data mark is 
      --            incountered, or 3). the current character is blank.
         I := I + 1;
         aChar := One_Line( I );
         
         -- if this is the first character, and if next character is
         --    a blank than this is a control character, treat is special
         if I = K then
            if ( aChar > '9' or aChar < '0' )    then
               if aChar = 'P'
               or aChar = 'E'
               or aChar = 'C'
               or aChar = Beginning_of_Data_Mark
               or aChar = End_of_Data_Mark       then
                  theEvent := aChar;
                  I := I + 1;
                  Next_not_Blank( I );
                  J := I;
               else
                  raise Not_a_Number;
               end if;
            else
               theEvent := 'D';
            end if;
         end if;
         if theEvent = Beginning_of_Data_Mark
         or theEvent = End_of_Data_Mark
         or I > L
         or aChar = ' ' then
            exit;
         end if;
      end loop;
      -- Asseration: J = 1st none black character and I = next blank chr
      
      -- convert string to integer
      if theEvent   = 'D'
      or theEvent   = 'E' then
         if I > J then
            anID := ID_Type(Integer'Value(One_Line(J..I-1)));
         else
            raise Not_a_Number;
         end if;
      end if;
      
      -- search for more data
      Next_not_Blank( I );
      J := I + 1;
      loop
      -- Invariant: each loop iteration moves pointer I closer to end of 
      --            a string, loop terminates when 1). I reaches end of
      --            line, or 2). the current character is blank.
         I := I + 1;
         if I > L
         or One_Line( I ) = ' ' then
            exit;
         end if;
         if One_Line( I ) = '.' then
            if K >= J then
               raise Not_a_Number;
            else
               K := I;
            end if;
         end if;
      end loop;
      -- Asseration: J = 1st none black character and I = next blank
      --             character and K = '.' character (decimal point)
      
      -- convert string to float
      if theEvent   = 'D'
      or theEvent   = 'E' then
         if K > J then
            aTime_Est := Time_Est_Type( ID_Type( 
                         Integer'Value( One_Line( J..K-1 ) ) ) );
         else
            raise Not_a_Number;
         end if;
         if K <= J
         or K >= I-1 then
            raise Not_a_Number;
         end if;
         TE_frac := Natural( Integer'Value(One_Line( K+1 .. I-1 )));
         aTime_Est := aTime_Est + Float( TE_frac ) / (10.0 ** ( I-K-1 ));
      end if;      
      Event             := theEvent;
      aCPU_Job.ID       := anID;
      aCPU_Job.Time_Est := aTime_Est;
      -- New_Line;
      
   end Get_1_Line;

-- ======================================================================

   -- Procedure     : Get_Initial_Data
   -- Precondition  : valid flight records
   -- Postcondition : none

   procedure Get_Initial_Data(   H :    out Data_Array_Type;
                               Num :    out natural               ) is
      
      A                      : Data_Array_Type;
      Count                  : Natural := 0;
      Not_Initial_Data       : Exception;
      aCPU_Job               : CPU_Job_Record;
      theEvent               : Character;
   
   begin  -- Get_Initial_Data
      while not End_of_File loop
      -- Asseration: read data file until end of file or until a
      --             beginning of data mark is read.
         Get_1_Line( theEvent, aCPU_Job );
         if theEvent = Beginning_of_Data_Mark then
            exit;
         end if;
      end loop;
      -- Inveriant: position input file at beginning of input data set
      
      if theEvent /= Beginning_of_Data_Mark then
         raise No_Valid_Input;
      else
         
         loop
         -- Inveriant: read input data file until end of file or until
         --            end of data mark is read
            begin -- input block
               Get_1_Line( theEvent, aCPU_Job );
               if    theEvent  = End_of_Data_Mark then
                  exit;
               elsif theEvent /= 'D' then
                  raise Not_Initial_Data;
               else
                  Count      := Count + 1;
                  A( Count ) := aCPU_Job;
               end if;
            exception
               when End_Error =>
                  exit;
               when Others =>
                  put( "  Invalid input, skipped" );
                  -- New_Line;
            end; -- input block
            New_Line;
         end loop;
         -- Asseration: array H of CPU_Job records
      
      end if;
      Num := Count;
      H   := A;
      exception
         when Others =>
            put( "Initial Input Array not Found" );
            New_Line;
   end Get_Initial_Data;

-- ======================================================================

   -- Procedure     : Waiting_Jobs_Get
   -- Precondition  : none
   -- Postcondition : array of waiting Jobs

   procedure Waiting_Jobs_Get(   H :    out Data_Array_Type;
                               Num :    out natural               ) is
   
   begin -- Wainting_Jobe_Get
      put( " . . . Loading initial Job Queue . . . " );
      New_Line( 2 );
      Get_Initial_Data( Initial_Data_Array, Num_of_Array_Elements );
      New_Line( 2 );
      put( " . . . use Heap to build Job Priority Queue (SJF) " );
      New_Line( 2 );
      Make_Null(  H        => CPU_Priority_Queue    );
      Build_Heap( Num      => Num_of_Array_Elements,
                  Raw_Data => Initial_Data_Array,
                  H        => CPU_Priority_Queue    );
   end Waiting_Jobs_Get;

-- ======================================================================

   -- Procedure     : Job_Submit
   -- Precondition  : valid binary heap, and valid data element
   -- Postcondition : new element added to priority queue

   procedure Job_Submit( X : in     CPU_Job_Record;
                         H : in out Priority_Queue) is
   
   begin -- Job_Submit
      -- insert a new job into schedule queue, report overflow if needed
      begin --
         Insert( X => aCPU_Job, 
                 H => CPU_Priority_Queue );
         put( "Added to Schedule Queue." );
      exception
         when overflow =>
            put( " -- not added, Queue is full" );
         when others =>
            put( "Unknown error ... ???" );
      end; --
   end Job_Submit;
   
-- ======================================================================

   -- Procedure     : Job_Process
   -- Precondition  : valid binary heap
   -- Postcondition : top element deleted from priority queue

   procedure Job_Process( H : in out Priority_Queue) is
   
   begin -- Job_Process
      -- from priority queue, get job with highest priority, print it
      -- if queue is empty, print idle message
      begin --
         Delete_Min( Min => aCPU_Job, 
                       H => CPU_Priority_Queue );
         Put_CPU_Job(  R => aCPU_Job ); 
         put( " --  Job processed." );
      exception
         when underflow =>
            put( "CPU is idle, now." );
         when others =>
            put( "Unknown error ... ???" );
      end; --
   end Job_Process;
   
-- ======================================================================

   -- Procedure     : Queue_Print
   -- Precondition  : valid binary heap
   -- Postcondition : none

   procedure Queue_Print( H : in out Priority_Queue) is
   
   begin -- Queue_Print
      -- print queue in inverted tree format
      begin --
         put( "Printing Job Priority Queue." );
         New_Line( 2 );
         Print_Heap(  H => CPU_Priority_Queue );
         New_Line( 2 ); 
      exception
         when underflow =>
            put( "Schedule Queue is empty, nothing to print." );
         when others =>
            put( "Unknown error ... ???" );
      end; --
   end Queue_Print;
   
-- ======================================================================
-- ======================================================================

begin -- CPU_Scheduler
   
   -- Open sample data file, for testing ONLY
   Text_IO.Open( File => sampleData, Mode => Text_IO.In_File,
               Name => "Prog9_Sample.dat" );
   Text_IO.Set_Input( File => sampleData );
   
   -- read initial data file
   put( "Computer System in Chaos ... running scheduler program ..." );
   New_Line( 2 );
   
   Waiting_Jobs_Get( H => Initial_Data_Array, 
                   Num => Num_of_Array_Elements );
   put( "System Ready . . ." );
   New_Line( 2 );
   
   while not End_of_File loop
   -- Inveriant: each loop itteration reads one job queue request, loop
   --            terminates with end of input file is reached.
      Begin -- input handler
         -- read and process Queue requests
         --          E - submit new job to priority queue
         --          C - process higest priority job, or report idle
         --          P - print the Queue, or report empty
         Get_1_Line( theEvent, aCPU_Job );
         Set_Col( To => 18 );
         put( " --  " );
         if    theEvent                             = 'E' then
            Job_Submit(  X => aCPU_Job, 
                         H => CPU_Priority_Queue );
         elsif theEvent                             = 'C' then
            Job_Process( H => CPU_Priority_Queue );
         elsif theEvent                             = 'P' then
            Queue_Print( H => CPU_Priority_Queue );
         else
            put( "Unknown input, skipped." );
         end if;
         New_Line;

         exception
            when Others =>
               put( "Invalid Input -- skipped." );
               New_Line;
      end; -- input handler
   end loop;
   -- Asseration: all input data processed, end of job ...
end CPU_Scheduler;


Converted with HTML Markup 1.1 by Scott J. Kleper
http://htc.rit.edu/klephacks/markup.html

ftp://htc.rit.edu/pub/HTML-Markup-current.hqx