[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