[Ada Information Clearinghouse]

Ada '83 Quality and Style:

Guidelines for Professional Programmers

Copyright 1989, 1991,1992 Software Productivity Consortium, Inc., Herndon, Virginia.

CHAPTER 10: Complete Examples

10.3 Window-Oriented Portable Dining Philosophers Example

Michael B. Feldman
Dept. of Electrical Engineering and Computer Science
The George Washington University
Washington, DC 20052

(202) 994-5253
mfeldman@seas.gwu.edu

Copyright 1991, Michael B. Feldman
These programs may be freely copied, distributed, and modified for educational purposes but not for profit. If you modify or enhance the program (for example, to use other display systems), please send Dr. Feldman a copy of the modified code, either on diskette or by e-mail.

This system is an elaborate implementation of Edsger Dijkstra's famous Dining Philosophers; a classical demonstration of deadlock problems in concurrent programming.

This example builds on some of the utilities found in the Line-Oriented example. 
------------------------------------------------------------------------ 
package Screen is

   -- Procedures for drawing pictures on ANSI Terminal Screen
   
   Screen_Depth : constant := 24; 
   Screen_Width : constant := 80;
   
   subtype Depth is Integer range 1 .. Screen_Depth; 
   subtype Width is Integer range 1 .. Screen_Width;
   
   procedure Beep; 
   procedure Clear_Screen; 
   procedure Move_Cursor (Column : in     Width; 
                          Row    : in     Depth);
                          
end Screen;

------------------------------------------------------------------------

with Screen; 
use  Screen; 
package Windows is

   type Window is private;
   
   procedure Open 
         (W      : in out Window;       -- Window variable returned 
          Row    : in     Depth;        -- Upper left corner 
          Column : in     Width; 
          Height : in     Depth;        -- Size of window 
          Width  : in     Screen.Width);
          
   -- Create a window variable and open the window for writing. 
   -- No checks for overlap of windows are made.
   
   procedure Close (W : in out Window); 
   -- Close window and clear window variable.
   
   procedure Title (W     : in out Window; 
                    Name  : in     String; 
                    Under : in     Character);
                    
   -- Put a title name at the top of the window.  If the parameter 
   -- Under is nonblank, underline the title with the 
   -- specified character.
   
   procedure Borders (W      : in out Window; 
                      Corner : in     Character; 
                      Down   : in     Character; 
                      Across : in     Character);
                      
   -- Draw border around current writable area in window with 
   -- characters specified.  Call this BEFORE Title.
   
   procedure Go_To_Row_Column (W      : in out Window; 
                               Row    : in     Depth; 
                               Column : in     Width);
                               
   -- Goto the row and column specified.  Coordinates are relative 
   -- to the upper left corner of window, which is (1, 1)
   
   procedure Put 
         (W  : in out Window; 
          Ch : in     Character);
          
   -- put one character to the window. 
   -- If end of column, go to the next row. 
   -- If end of window, go to the top of the window.
   
   procedure Put_String (W : in out Window; 
                         S : in     String);

   -- put a string to window.

   procedure New_Line (W : in out Window);

   -- Go to beginning of next line.  Next line is 
   -- not blanked until next character is written

private

   type Window is 
      record 
         Current_Row    : Depth;          -- Current cursor row 
         First_Row      : Depth; 
         Last_Row       : Depth;

         Current_Column : Width;          -- Current cursor column 
         First_Column   : Width; 
         Last_Column    : Width;

      end record;

end Windows;

------------------------------------------------------------------------

with Text_IO; 
package body Screen is

   package My_Int_IO is new Text_IO.Integer_IO (Integer);

   -- Procedures for drawing pictures on ANSI Terminal Screen

   --------------------------------------------------------------------- 
   procedure Beep is 
   begin 
      Text_IO.Put(Item => ASCII.Bel); 
   end Beep;

   ---------------------------------------------------------------------

   procedure Clear_Screen is 
   begin 
      Text_IO.Put(Item => ASCII.Esc); 
      Text_IO.Put(Item => "[2J"); 
   end Clear_Screen;

   ---------------------------------------------------------------------

   procedure Move_Cursor (Column : in     Width; 
                          Row    : in     Depth) is 
   begin 
      Text_IO.New_Line; 
      Text_IO.Put(Item => ASCII.Esc); 
      Text_IO.Put("["); 
      My_Int_IO.Put (Item  => Row, 
                     Width => 1); 
      Text_IO.Put(Item => ';'); 
      My_Int_IO.Put (Item  => Column, 
                     Width => 1); 
      Text_IO.Put(Item => 'f'); 
   end Move_Cursor;

   ---------------------------------------------------------------------

end Screen;

------------------------------------------------------------------------

with Text_IO; 
with Medium_Integer_IO; 
with Screen;

use  Text_IO; 
use  Medium_Integer_IO; 
use  Screen;

package body Windows is

   Cursor_Row : Depth := 1;            -- Current cursor position 
   Cursor_Col : Width := 1;

   --------------------------------------------------------------------- 
   procedure Open 
         (W      : in out Window; 
          Row    : in     Depth; 
          Column : in     Width; 
          Height : in     Depth; 
          Width  : in     Screen.Width) is

      --Put the Window's cursor in upper left corner 
   begin 
      W.Current_Row := Row; 
      W.First_Row := Row; 
      W.Last_Row := Row + Height - 1;

      W.Current_Column := Column; 
      W.First_Column := Column; 
      W.Last_Column := Column + Width - 1; 
   end Open;

   ---------------------------------------------------------------------

   procedure Close (W : in out Window) is 
   begin 
      null; 
   end Close;

   ---------------------------------------------------------------------

   procedure Title (W     : in out Window; 
                    Name  : in     String; 
                    Under : in     Character) is

      -- Put name at the top of the Window.  If Under nonblank, 
      -- underline the title. 
   begin 
      -- Put name on top line 
      W.Current_Column := W.First_Column; 
      W.Current_Row := W.First_Row; 
      Put_String(W, Name); 
      New_Line(W);

      -- Underline name if desired, and move the First line 
      -- of the Window below the title 
      if Under = ' ' then 
         W.First_Row := W.First_Row + 1;

      else  -- put nonblank characters under title 
         for I in W.First_Column .. W.Last_Column loop 
            Put(W, Under); 
         end loop; 
         New_Line(W); 
         W.First_Row := W.First_Row + 2; 
      end if;

   end Title;

   ---------------------------------------------------------------------

   procedure Go_To_Row_Column (W      : in out Window; 
                               Row    : in     Depth; 
                               Column : in     Width) is

      -- Relative to writable Window boundaries, of course 
   begin 
      W.Current_Row    := W.First_Row    + Row; 
      W.Current_Column := W.First_Column + Column; 
   end Go_To_Row_Column;

   ---------------------------------------------------------------------

   procedure Borders (W      : in out Window; 
                      Corner : in     Character; 
                      Down   : in     Character; 
                      Across : in     Character) is

      -- Draw border around current writable area in Window 
      -- with characters. Call this BEFORE Title. 
   begin

      -- Put top line of border 
      Screen.Move_Cursor(W.First_Column, W.First_Row); 
      Text_IO.Put(Corner);

      for J in W.First_Column + 1 .. W.Last_Column - 1 loop 
         Text_IO.Put(Across); 
      end loop; 
      Text_IO.Put(Corner);

      -- Put the two side lines 
      for I in W.First_Row + 1 .. W.Last_Row - 1 loop 
         Screen.Move_Cursor(W.First_Column, I); 
         Text_IO.Put(Down); 
         Screen.Move_Cursor(W.Last_Column, I); 
         Text_IO.Put(Down); 
      end loop;

      -- Put the bottom line of the border 
      Screen.Move_Cursor(W.First_Column, W.Last_Row); 
      Text_IO.Put(Corner); 
      for J in W.First_Column + 1 .. W.Last_Column - 1 loop 
         Text_IO.Put(Across); 
      end loop; 
      Text_IO.Put(Corner);

      -- Put the cursor at the very end of the Window 
      Cursor_Row := W.Last_Row; 
      Cursor_Col := W.Last_Column + 1;

      -- Make the Window smaller by one character on each side 
      W.First_Row := W.First_Row + 1; 
      W.Current_Row := W.First_Row; 
      W.Last_Row := W.Last_Row - 1; 
      W.First_Column := W.First_Column + 1; 
      W.Current_Column := W.First_Column; 
      W.Last_Column := W.Last_Column - 1; 
   end Borders;
   
   ---------------------------------------------------------------------
   
   procedure Erase_To_End_Of_Line (W : in out Window) is 
   begin 
      Screen.Move_Cursor(W.Current_Column, W.Current_Row);
      
      for I in W.Current_Column .. W.Last_Column loop 
         Text_IO.Put(' '); 
      end loop;
      
      Screen.Move_Cursor(W.Current_Column, W.Current_Row); 
      Cursor_Col := W.Current_Column; 
      Cursor_Row := W.Current_Row; 
   end Erase_To_End_Of_Line;
   
   ---------------------------------------------------------------------
   
   procedure Put (W  : in out Window; 
                  Ch : in     Character) is
                  
      -- If after end of line, move to First character of next line 
      -- If about to write First character on line, blank rest of 
      -- line. 
      -- Put character.
      
   begin 
      if Ch = ASCII.CR then 
         New_Line(W);
         
         return;
         
      end if;
      
      -- If at end of current line, move to next line 
      if W.Current_Column > W.Last_Column then
      
         if W.Current_Row = W.Last_Row then 
            W.Current_Row := W.First_Row;
            
         else  -- not at end of current line 
            W.Current_Row := W.Current_Row + 1; 
         end if;
         
         W.Current_Column := W.First_Column; 
      end if;
      
      -- If at W.First char, erase line 
      if W.Current_Column = W.First_Column then 
         Erase_To_End_Of_Line(W); 
      end if;
      
      -- Put physical cursor at Window's cursor 
      if Cursor_Col /= W.Current_Column or 
         Cursor_Row /= W.Current_Row    then
         
         Screen.Move_Cursor(W.Current_Column, W.Current_Row); 
         Cursor_Row := W.Current_Row; 
      end if;
      
      if Ch = ASCII.BS then 
         -- Special backspace handling 
         if W.Current_Column /= W.First_Column then 
            Text_IO.Put(Ch); 
            W.Current_Column := W.Current_Column - 1; 
         end if;
         
      else  -- character is not a backspace, so just write it 
         Text_IO.Put(Ch); 
         W.Current_Column := W.Current_Column + 1; 
      end if;
      
      Cursor_Col := W.Current_Column; 
   end Put;
   
   ---------------------------------------------------------------------
   
   procedure New_Line (W : in out Window) is
   
      Col : Width;
      
      -- If not after line, blank rest of line. 
      -- Move to First character of next line 
   begin  -- New_Line
   
      if W.Current_Column = 0 then 
         Erase_To_End_Of_Line(W); 
      end if;
      
      if W.Current_Row = W.Last_Row then 
         W.Current_Row := W.First_Row;
         
      else  -- not at bottom of screen 
         W.Current_Row := W.Current_Row + 1; 
      end if;
      
      W.Current_Column := W.First_Column; 
   end New_Line;
   
   ---------------------------------------------------------------------
   
   procedure Put_String (W : in out Window; 
                         S : in     String) is 
   begin 
      for I in S'First .. S'Last loop 
         Put(W, S(I)); 
      end loop; 
   end Put_String;
   
   ---------------------------------------------------------------------
   
begin  -- Windows 
   Screen.Clear_Screen; 
   Screen.Move_Cursor(1, 1); 
end Windows;

------------------------------------------------------------------------

with SPC_Numeric_Types; 
with Windows; 
with Chop; 
with Phil; 
with Calendar;

use  SPC_Numeric_Types;

pragma Elaborate (Phil); 
package body Room is

   Phils        : array (Table_Type) of Phil.Philosopher; 
   Phil_Windows : array (Table_Type) of Windows.Window;
   
   type Phil_Names is (Dijkstra, Texel, Booch, Ichbiah, Stroustrup);
   
   task body Head_Waiter is
   
      T          : Medium_Positive; 
      Start_Time : Calendar.Time;
      
   begin  -- Head_Waiter
   
      accept Open_The_Room; 
      Start_Time := Calendar.Clock;
      
      Windows.Open (W      => Phil_Windows(1), 
                    Row    => 1, 
                    Column => 23, 
                    Height => 7, 
                    Width  => 30);

      Windows.Borders(Phil_Windows(1), '+', '|', '-'); 
      Windows.Title  (Phil_Windows(1), "Eddy Dijkstra", '-'); 
      Phils(1).Come_To_Life(1, 1, 2);
      
      Windows.Open (W      => Phil_Windows(3), 
                    Row    => 9, 
                    Column => 50, 
                    Height => 7, 
                    Width  => 30);

      Windows.Borders(Phil_Windows(3), '+', '|', '-'); 
      Windows.Title  (Phil_Windows(3), "Grady Booch", '-'); 
      Phils(3).Come_To_Life(3, 3, 4);
      
      Windows.Open (W      => Phil_Windows(2), 
                    Row    => 9, 
                    Column => 2, 
                    Height => 7, 
                    Width  => 30);

      Windows.Borders(Phil_Windows(2), '+', '|', '-'); 
      Windows.Title  (Phil_Windows(2), "Putnam Texel", '-'); 
      Phils(2).Come_To_Life(2, 2, 3);
      
      Windows.Open (W      => Phil_Windows(5), 
                    Row    => 17, 
                    Column => 41, 
                    Height => 7, 
                    Width  => 30);

      Windows.Borders(Phil_Windows(5), '+', '|', '-'); 
      Windows.Title  (Phil_Windows(5), "Bjarne Stroustrup", '-'); 
      Phils(5).Come_To_Life(5, 1, 5);
      
      Windows.Open (W      => Phil_Windows(4), 
                    Row    => 17, 
                    Column => 8, 
                    Height => 7, 
                    Width  => 30);

      Windows.Borders(Phil_Windows(4), '+', '|', '-'); 
      Windows.Title  (Phil_Windows(4), "Jean Ichbiah", '-'); 
      Phils(4).Come_To_Life(4, 4, 5);
      
      loop 
         select 
            accept Report_State 
                  (Which_Phil : in     Table_Type; 
                   State      : in     Phil.States; 
                   How_Long   : in     Medium_Natural := 0) do 
               T := 
                     Medium_Natural 
                        (Calendar."-"(Calendar.Clock, Start_Time)); 
               Windows.Put_String 
                        (Phil_Windows(Which_Phil), 
                         "T=" & Medium_Natural'Image(T) & " "); 
               case State is 
                  when Phil.Breathing => 
                     Windows.Put_String 
                              (Phil_Windows(Which_Phil), 
                               "Breathing..."); 
                     Windows.New_Line(Phil_Windows(Which_Phil));
                     
                  when Phil.Thinking => 
                     Windows.Put_String 
                        (Phil_Windows(Which_Phil), 
                         "Thinking" & Medium_Natural'Image(How_Long) & 
                         " seconds."); 
                     Windows.New_Line(Phil_Windows(Which_Phil));
                     
                  when Phil.Eating => 
                     Windows.Put_String 
                        (Phil_Windows(Which_Phil), 
                         "Eating" & Medium_Natural'Image(How_Long) & 
                         " seconds."); 
                     Windows.New_Line(Phil_Windows(Which_Phil));
                     
                  when Phil.Done_Eating => 
                     Windows.Put_String 
                              (Phil_Windows(Which_Phil), 
                               "Yum-yum (burp)"); 
                     Windows.New_Line(Phil_Windows(Which_Phil));
                     
                  when Phil.Got_One_Stick => 
                     Windows.Put_String 
                        (Phil_Windows(Which_Phil), 
                         "First chopstick" & 
                         Medium_Natural'Image(How_Long)); 
                     Windows.New_Line(Phil_Windows(Which_Phil));
                     
                  when Phil.Got_Other_Stick => 
                     Windows.Put_String 
                        (Phil_Windows(Which_Phil), 
                         "Second chopstick" & 
                         Medium_Natural'Image(How_Long)); 
                     Windows.New_Line(Phil_Windows(Which_Phil));
                     
               end case;
               
            end Report_State; 
         or 
            terminate; 
         end select;
         
      end loop;
      
   -- An exception handler is not needed here. 
   end Head_Waiter;
   
end Room; 
------------------------------------------------------------------------

Back to document index