Ada Style Guide/Portable Dining Philosophers Example

From Wikibooks, open books for an open world
Jump to: navigation, search

Improving Performance · References


This chapter presents an elaborate implementation of Edsger Dijkstra's famous Dining Philosophers; a classical demonstration of deadlock problems in concurrent programming. This example demonstrates the portability of Ada packages and tasking and illustrates many of the Ada 95 quality and style guidelines. Since many of the guidelines leave the program writer to decide what is best, there is no single best or correct example of how to use Ada. Instead, you will find several styles that differ from your own that may deserve consideration.


--::::::::::
--random_generic.ads
--::::::::::
generic
  type Result_Subtype is (<>);
package Random_Generic is
 
  -- Simple integer pseudo-random number generator package.
  -- Michael B. Feldman, The George Washington University, 
  -- June 1995.
 
  function Random_Value return Result_Subtype;  
 
end Random_Generic;
--::::::::::
--screen.ads
--::::::::::
package Screen is
 
  -- simple ANSI terminal emulator
  -- Michael Feldman, The George Washington University
  -- July, 1995
 
  ScreenHeight : constant Integer := 24;
  ScreenWidth  : constant Integer := 80;
 
  subtype Height is Integer range 1 .. ScreenHeight;
  subtype Width  is Integer range 1 .. ScreenWidth;
 
  type Position is record
    Row    : Height := 1;
    Column : Width  := 1;
  end record;
 
  procedure Beep; 
  -- Pre:  none
  -- Post: the terminal beeps once
 
  procedure ClearScreen; 
  -- Pre:  none
  -- Post: the terminal screen is cleared
 
  procedure MoveCursor (To : in Position);
  -- Pre:  To is defined
  -- Post: the terminal cursor is moved to the given position
 
end Screen;   
--::::::::::
--windows.ads
--::::::::::
with Screen;
package Windows is
 
  -- manager for simple, nonoverlapping screen windows
  -- Michael Feldman, The George Washington University
  -- July, 1995
 
  type Window is private;
 
  function Open (UpperLeft : Screen.Position;
                 Height    : Screen.Height;
                 Width     : Screen.Width) return Window;
  -- Pre:  W, Height, and Width are defined
  -- Post: returns a Window with the given upper-left corner,
  --   height, and width
 
  procedure Title (W     : in out Window;
                   Name  : in     String;
                   Under : in     Character);
  -- Pre:  W, Name, and Under are defined
  -- Post: Name is displayed at the top of the window W, underlined
  -- with the character Under. 
 
  procedure Borders (W      : in out Window;
                     Corner : in     Character
                     Down   : in     Character
                     Across : in     Character);
  -- Pre:  All parameters are defined
  -- Post: Draw border around current writable area in window with 
  -- characters specified.  Call this BEFORE Title.  
 
  procedure MoveCursor (W : in out Window;
                        P : in     Screen.Position);
  -- Pre:  W and P are defined, and P lies within the area of W
  -- Post: Cursor is moved to the specified position.
  --   Coordinates are relative to the
  --   upper left corner of W, which is (1, 1) 
 
  procedure Put (W  : in out Window;
                 Ch : in     Character);
  -- Pre:  W and Ch are defined.
  -- Post: Ch is displayed in the window at 
  --   the next available position.
  --   If end of column, go to the next row.
  --   If end of window, go to the top of the window. 
 
  procedure Put (W : in out Window;
                 S : in     String);
  -- Pre:  W and S are defined
  -- Post: S is displayed in the window, "line-wrapped" if necessary
 
  procedure New_Line (W : in out Window);
  -- Pre:  W is defined
  -- Post: Cursor moves to beginning of next line of W;
  --   line is not blanked until next character is written  
 
private
  type Window is record
    First   : Screen.Position; -- coordinates of upper left
    Last    : Screen.Position; -- coordinates of lower right
    Current : Screen.Position; -- current cursor position
  end record;
 
end Windows;
--::::::::::
--Picture.ads
--::::::::::
with Windows;
with Screen;
package Picture is
 
  -- Manager for semigraphical presentation of the philosophers
  -- i.e. more application oriented windows, build on top of
  -- the windows package.
  -- Each picture has an orientation, which defines which borders
  -- top-bottom, bottom-top, left-right, or right-left correspond
  -- to the left and right hand of the philosopher.
  --
  -- Bjorn Kallberg, CelsiusTech Systems, Sweden
  -- July, 1995
 
  type Root is abstract tagged private;
  type Root_Ptr is access Root'Class;
 
  procedure Open (W         : in out Root;
                  UpperLeft : in     Screen.Position;
                  Height    : in     Screen.Height;
                  Width     : in     Screen.Width);
  -- Pre:  Not opened
  -- Post: An empty window exists
 
  procedure Title (W     : in out Root;
                   Name  : in     String);
  -- Pre:  An empty window
  -- Post: Name and a border is drawn.
 
  procedure Put_Line (W : in out Root; 
                      S : in     String);
 
  procedure Left_Fork  (W    : in out Root; 
                        Pick : in     Boolean) is abstract;
  procedure Right_Fork (W    : in out Root; 
                        Pick : in     Boolean) is abstract;
  -- left and right relates to philosopher position around table
 
  type North is new Root with private;
  type South is new Root with private;
  type East  is new Root with private;
  type West  is new Root with private;
 
 
private
  type Root is abstract tagged record
      W : Windows.Window;
  end record;
 
  type North is new Root with null record;
  type South is new Root with null record;
  type East  is new Root with null record;
  type West  is new Root with null record;
 
  procedure Left_Fork  (W    : in out North; 
                        Pick : in     Boolean);
  procedure Right_Fork (W    : in out North; 
                        Pick : in     Boolean);
 
  procedure Left_Fork  (W    : in out South; 
                        Pick : in     Boolean);
  procedure Right_Fork (W    : in out South; 
                        Pick : in     Boolean);
 
  procedure Left_Fork  (W    : in out East; 
                        Pick : in     Boolean);
  procedure Right_Fork (W    : in out East; 
                        Pick : in     Boolean);
 
  procedure Left_Fork  (W    : in out West; 
                        Pick : in     Boolean);
  procedure Right_Fork (W    : in out West; 
                        Pick : in     Boolean);
 
end Picture;
--::::::::::
--chop.ads
--::::::::::
package Chop is
 
  -- Dining Philosophers - Ada 95 edition
  -- Chopstick is an Ada 95 protected type
  -- Michael B. Feldman, The George Washington University,
  -- July, 1995.
 
  protected type Stick is
    entry Pick_Up;
    procedure Put_Down;
  private
    In_Use: Boolean := False;
  end Stick;
 
end Chop;
 
--::::::::::
--society.ads
--::::::::::
package Society is
 
  -- Dining Philosophers - Ada 95 edition
  -- Society gives unique ID's to people, and registers their names
  -- Michael B. Feldman, The George Washington University,
  -- July, 1995.
 
  subtype Unique_DNA_Codes is Positive range 1 .. 5;
 
  Name_Register : array (Unique_DNA_Codes) of String (1 .. 18) :=
 
     ("Edsger Dijkstra   ",
      "Bjarne Stroustrup ",
      "Chris Anderson    ",
      "Tucker Taft       ",
      "Jean Ichbiah      ");
 
end Society;
--::::::::::
--phil.ads
--::::::::::
with Society;
package Phil is
 
  -- Dining Philosophers - Ada 95 edition
  -- Philosopher is an Ada 95 task type with discriminant
  -- Michael B. Feldman, The George Washington University,
  -- July 1995
  --
  -- Revisions:
  -- July 1995. Bjorn Kallberg, CelsiusTech
  --            Reporting left or right instead of first stick
 
  task type Philosopher (My_ID : Society.Unique_DNA_Codes) is
 
    entry Start_Eating (Chopstick1 : in Positive;
                        Chopstick2 : in Positive);
 
  end Philosopher;
 
  type States is (Breathing, Thinking, Eating, Done_Eating, 
                  Got_Left_Stick, Got_Right_Stick, Got_Other_Stick, Dying);
 
end Phil;
--::::::::::
--room.ads
--::::::::::
with Chop;
with Phil;
with Society;
package Room is
 
  -- Dining Philosophers - Ada 95 edition
 
  -- Room.Maitre_D is responsible for assigning seats at the
  --   table, "left" and "right" chopsticks, and for reporting
  --   interesting events to the outside world.
 
  -- Michael B. Feldman, The George Washington University,
  -- July, 1995.
 
  Table_Size : constant := 5;
  subtype Table_Type is Positive range 1 .. Table_Size;
 
  Sticks : array (Table_Type) of Chop.Stick;
 
  task Maitre_D is
    entry Start_Serving;
    entry Report_State (Which_Phil : in Society.Unique_DNA_Codes;
                        State      : in Phil.States;
                        How_Long   : in Natural := 0;
                        Which_Meal : in Natural := 0);
  end Maitre_D;
 
end Room;
--::::::::::
--random_generic.adb
--::::::::::
with Ada.Numerics.Discrete_Random;
package body Random_Generic is
 
  -- Body of random number generator package.
  -- Uses Ada 95 random number generator; hides generator parameters
  -- Michael B. Feldman, The George Washington University, 
  -- June 1995.
 
  package Ada95_Random is new Ada.Numerics.Discrete_Random
    (Result_Subtype => Result_Subtype);
 
  G : Ada95_Random.Generator;
 
  function Random_Value return Result_Subtype is 
  begin
    return Ada95_Random.Random (Gen => G);
  end Random_Value;
 
begin -- Random_Generic
 
  Ada95_Random.Reset (Gen => G);  -- time-dependent initialization
 
end Random_Generic;
--::::::::::
--screen.adb
--::::::::::
with Text_IO;
package body Screen is
 
  -- simple ANSI terminal emulator
  -- Michael Feldman, The George Washington University
  -- July, 1995
 
  -- These procedures will work correctly only if the actual
  -- terminal is ANSI compatible. ANSI.SYS on a DOS machine
  -- will suffice.
 
  package Int_IO is new Text_IO.Integer_IO (Num => Integer);
 
  procedure Beep is
  begin
    Text_IO.Put (Item => ASCII.BEL);
  end Beep;
 
  procedure ClearScreen is
  begin
    Text_IO.Put (Item => ASCII.ESC);
    Text_IO.Put (Item => "[2J");
  end ClearScreen;
 
  procedure MoveCursor (To : in Position) is
  begin                                                
    Text_IO.New_Line;
    Text_IO.Put (Item => ASCII.ESC);
    Text_IO.Put ("[");
    Int_IO.Put (Item => To.Row, Width => 1);
    Text_IO.Put (Item => ';');
    Int_IO.Put (Item => To.Column, Width => 1);
    Text_IO.Put (Item => 'f');
  end MoveCursor;  
 
end Screen;
--::::::::::
--windows.adb
--::::::::::
with Text_IO, with Screen;
package body Windows is
 
  -- manager for simple, nonoverlapping screen windows
  -- Michael Feldman, The George Washington University
  -- July, 1995
 
  function Open (UpperLeft : Screen.Position;
                 Height    : Screen.Height;
                 Width     : Screen.Width) return Window is
    Result : Window;
  begin
    Result.Current := UpperLeft;
    Result.First   := UpperLeft;
    Result.Last    := (Row    => UpperLeft.Row + Height - 1, 
                       Column => UpperLeft.Column + Width - 1);
    return Result; 
  end Open;
 
  procedure EraseToEndOfLine (W : in out Window) is
  begin
    Screen.MoveCursor (W.Current);
    for Count in W.Current.Column .. W.Last.Column loop
      Text_IO.Put (' ');
    end loop;
    Screen.MoveCursor (W.Current);
  end EraseToEndOfLine;
 
  procedure Put (W  : in out Window;
                 Ch : in     Character) is
  begin
 
    -- 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
        W.Current.Row := W.Current.Row + 1;
      end if;
      W.Current.Column := W.First.Column;
    end if;
 
    -- If at First char, erase line
    if W.Current.Column = W.First.Column then
      EraseToEndOfLine (W);
    end if;
 
    Screen.MoveCursor (To => W.Current);
 
     -- here is where we actually write the character!
     Text_IO.Put (Ch);
     W.Current.Column := W.Current.Column + 1;
 
  end Put;
 
  procedure Put (W : in out Window;
                 S : in     String) is
  begin
    for Count in S'Range loop
      Put (W, S (Count));
    end loop;
  end Put;
 
  procedure New_Line (W : in out Window) is
  begin
    if W.Current.Column = 1 then
      EraseToEndOfLine (W);
    end if;
    if W.Current.Row = W.Last.Row then
      W.Current.Row := W.First.Row;
    else
      W.Current.Row := W.Current.Row + 1;
    end if;
    W.Current.Column := W.First.Column;
  end New_Line;
  procedure Title (W     : in out Window;
                   Name  : in     String;
                   Under : in     Character) is
  begin
    -- Put name on top line
    W.Current := W.First;
    Put (W, Name);
    New_Line (W);
    -- Underline name if desired, and reduce the writable area
    -- of the window by one line
    if Under = ' ' then   -- no underlining
      W.First.Row := W.First.Row + 1;      
    else                  -- go across the row, underlining
      for Count in W.First.Column .. W.Last.Column loop 
        Put (W, Under);
      end loop;
      New_Line (W);
      W.First.Row := W.First.Row + 2; -- reduce writable area
    end if;
  end Title;
 
  procedure Borders (W       : in out Window;
                     Corner  : in     Character
                     Down    : in     Character
                     Across  : in     Character is
, 
  begin
    -- Put top line of border
    Screen.MoveCursor (W.First);
    Text_IO.Put (Corner);
    for Count 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 Count in W.First.Row + 1 .. W.Last.Row - 1 loop
      Screen.MoveCursor ((Row => Count, Column => W.First.Column));
      Text_IO.Put (Down);
      Screen.MoveCursor ((Row => Count, Column => W.Last.Column));
      Text_IO.Put (Down);
    end loop;
 
    -- Put the bottom line of the border
    Screen.MoveCursor ((Row => W.Last.Row, Column => W.First.Column));
    Text_IO.Put (Corner);
    for Count in W.First.Column + 1 .. W.Last.Column - 1 loop
      Text_IO.Put (Across);
    end loop;
    Text_IO.Put (Corner);
 
    -- Make the Window smaller by one character on each side
    W.First   := (Row => W.First.Row + 1, Column => W.First.Column + 1);
    W.Last    := (Row => W.Last.Row - 1,  Column => W.Last.Column - 1);
    W.Current := W.First;
  end Borders;
 
  procedure MoveCursor (W : in out Window;
                        P : in     Screen.Position) is
    -- Relative to writable Window boundaries, of course
  begin 
    W.Current.Row    := W.First.Row + P.Row;
    W.Current.Column := W.First.Column + P.Column;
  end MoveCursor;
 
begin -- Windows
 
  Text_IO.New_Line;
  Screen.ClearScreen;
  Text_IO.New_Line;
 
end Windows;
--------------------
package Windows.Util is
  --
  -- Child package to change the borders of an existing window
  -- Bjorn Kallberg, CelsiusTech Systems, Sweden
  -- July, 1995.
 
  -- call these procedures after border and title
  procedure Draw_Left   (W  : in out Window; 
                         C  : in     Character);
  procedure Draw_Right  (W  : in out Window; 
                         C  : in     Character);
  procedure Draw_Top    (W  : in out Window; 
                         C  : in     Character);
  procedure Draw_Bottom (W  : in out Window; 
                         C  : in     Character);
 
end Windows.Util;
--------------------
with Text_IO;
package body Windows.Util is
 
  -- Bjorn Kallberg, CelsiusTech Systems, Sweden
  -- July, 1995.
 
  -- When making borders and titles, the size has shrunk, so
  -- we must now draw outside the First and Last points
 
 
   procedure Draw_Left (W  : in out Window; 
                        C  : in     Character) is
   begin
     for R in W.First.Row - 3  .. W.Last.Row + 1 loop
       Screen.MoveCursor ((Row => R, Column => W.First.Column-1));
       Text_IO.Put (C);
      end loop;
   end;
 
   procedure Draw_Right (W  : in out Window; 
                         C  : in     Character) is
   begin
     for R in W.First.Row - 3  .. W.Last.Row + 1 loop
       Screen.MoveCursor ((Row => R, Column => W.Last.Column + 1));
       Text_IO.Put (C);
     end loop;
   end;
 
   procedure Draw_Top (W  : in out Window; 
                       C  : in     Character) is
   begin
     for I in W.First.Column - 1 .. W.Last.Column + 1 loop
       Screen.MoveCursor ((Row => W.First.Row - 3, Column => I));
       Text_IO.Put (C);
     end loop;
   end;
 
   procedure Draw_Bottom (W  : in out Window; 
                          C  : in     Character) is
   begin
     for I in W.First.Column - 1 .. W.Last.Column + 1 loop
       Screen.MoveCursor ((Row => W.Last.Row + 1, Column => I));
       Text_IO.Put (C);
     end loop;
   end;
 
end Windows.Util;
 
--::::::::::
--Picture.adb
--::::::::::
with Windows.Util;
package body Picture is
  -- 
  -- Bjorn Kallberg, CelsiusTech Systems, Sweden
  -- July, 1995
 
 
  function Vertical_Char (Stick : Boolean) return Character is
  begin
     if Stick then 
        return '#'; 
     else 
       return ':'; 
     end if;
  end;
 
  function Horizontal_Char (Stick : Boolean) return Character is
  begin
    if Stick then 
       return '#'; 
    else 
       return '-'; 
    end if;
  end;
 
 
  procedure Open (W         : in out Root;
                  UpperLeft : in     Screen.Position;
                  Height    : in     Screen.Height;
                  Width     : in     Screen.Width) is
  begin 
     W.W := Windows.Open (UpperLeft, Height, Width);
  end;
 
 
  procedure Title (W     : in out Root;
                   Name  : in     String) is
  -- Pre:  An empty window
  -- Post: Name and a boarder is drawn.
 
  begin
      Windows.Borders (W.W, '+', ':', '-');
      Windows.Title (W.W, Name,'-');
  end;
 
  procedure Put_Line (W : in out Root; 
                      S : in     String) is
  begin
     Windows.Put (W.W, S);
     Windows.New_Line (W.W);
  end;
 
 
  -- North
  procedure Left_Fork  (W    : in out North; 
                        Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Right (W.W, Vertical_Char (Pick));
  end; 
 
  procedure Right_Fork  (W    : in out North; 
                         Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Left (W.W, Vertical_Char (Pick));
  end;
 
 
  -- South
  procedure Left_Fork  (W    : in out South; 
                        Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Left (W.W, Vertical_Char (Pick));
  end;
 
  procedure Right_Fork  (W    : in out South; 
                         Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Right (W.W, Vertical_Char (Pick));
  end;
 
 
  -- East
  procedure Left_Fork  (W    : in out East; 
                        Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Bottom (W.W, Horizontal_Char (Pick));
  end;
  procedure Right_Fork  (W    : in out East; 
                         Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Top (W.W, Horizontal_Char (Pick));
  end;
 
 
  -- West
  procedure Left_Fork  (W    : in out West; 
                        Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Top (W.W, Horizontal_Char (Pick));
  end;
 
  procedure Right_Fork  (W    : in out West; 
                         Pick : in     Boolean) is
  begin
     Windows.Util.Draw_Bottom (W.W, Horizontal_Char (Pick));
  end;
 
 
end Picture;
 
--::::::::::
--chop.adb
--::::::::::
package body Chop is
 
  -- Dining Philosophers - Ada 95 edition
  -- Chopstick is an Ada 95 protected type
  -- Michael B. Feldman, The George Washington University,
  -- July, 1995.
 
  protected body Stick is
 
    entry Pick_Up when not In_Use is
    begin
      In_Use := True;
    end Pick_Up;
 
    procedure Put_Down is
    begin
      In_Use := False;
    end Put_Down;
 
  end Stick;
 
end Chop;
--::::::::::
--phil.adb
--::::::::::
with Society;
with Room;
with Random_Generic;
package body Phil is
 
  -- Dining Philosophers - Ada 95 edition
  -- Philosopher is an Ada 95 task type with discriminant.
 
  -- Chopsticks are assigned by a higher authority, which
  --   can vary the assignments to show different algorithms.
  -- Philosopher always grabs First_Grab, then Second_Grab.
  -- Philosopher is oblivious to outside world, but needs to
  --   communicate is life-cycle events the Maitre_D.
  -- Chopsticks assigned to one philosopher must be
  -- consecutive numbers, or the first and last chopstick.
 
  -- Michael B. Feldman, The George Washington University,
  -- July, 1995.
  -- Revisions:
  -- July, 1995. Bjorn Kallberg, CelsiusTech
 
  subtype Think_Times is Positive range 1 .. 8;
  package Think_Length is 
    new Random_Generic (Result_Subtype => Think_Times);
 
  subtype Meal_Times is Positive range 1 .. 10;
  package Meal_Length is
    new Random_Generic (Result_Subtype => Meal_Times);
 
  task body Philosopher is  -- My_ID is discriminant
 
    subtype Life_Time is Positive range 1 .. 5;
 
    Who_Am_I    : Society.Unique_DNA_Codes := My_ID; -- discriminant
    First_Grab  : Positive;
    Second_Grab : Positive;
    Meal_Time   : Meal_Times; 
    Think_Time  : Think_Times;
    First_Stick : States;
 
  begin
      -- get assigned the first and second chopsticks here
    accept Start_Eating (Chopstick1 : in Positive;
                         Chopstick2 : in Positive) do
      First_Grab  := Chopstick1;
      Second_Grab := Chopstick2;
      if (First_Grab mod Room.Table_Type'Last) + 1 = Second_Grab then
         First_Stick := Got_Right_Stick;
      else
         First_Stick := Got_Left_Stick;
      end if;
    end Start_Eating;
    Room.Maitre_D.Report_State (Who_Am_I, Breathing);
 
    for Meal in Life_Time loop
      Room.Sticks (First_Grab).Pick_Up;
      Room.Maitre_D.Report_State (Who_Am_I, First_Stick, First_Grab);
      Room.Sticks (Second_Grab).Pick_Up;
      Room.Maitre_D.Report_State (Who_Am_I, Got_Other_Stick, Second_Grab);
      Meal_Time := Meal_Length.Random_Value;
      Room.Maitre_D.Report_State (Who_Am_I, Eating, Meal_Time, Meal);
      delay Duration (Meal_Time);
      Room.Maitre_D.Report_State (Who_Am_I, Done_Eating);
      Room.Sticks (First_Grab).Put_Down;
      Room.Sticks (Second_Grab).Put_Down;
      Think_Time := Think_Length.Random_Value; 
      Room.Maitre_D.Report_State (Who_Am_I, Thinking, Think_Time);
      delay Duration (Think_Time);
    end loop;
    Room.Maitre_D.Report_State (Who_Am_I, Dying);
  end Philosopher;
end Phil;
--::::::::::
--room.adb
--::::::::::
with Picture;
with Chop;
with Phil;
with Society;
with Calendar;
pragma Elaborate (Phil);
package body Room is
 
  -- Dining Philosophers, Ada 95 edition
  -- A line-oriented version of the Room package
  -- Michael B. Feldman, The George Washington University, 
  -- July, 1995.
  -- Revisions
  -- July, 1995. Bjorn Kallberg, CelsiusTech Systems, Sweden.
  --             Pictorial display of stick in use 
 
  -- philosophers sign into dining room, giving Maitre_D their DNA code
 
  Dijkstra   : aliased Phil.Philosopher (My_ID => 1);
  Stroustrup : aliased Phil.Philosopher (My_ID => 2);
  Anderson   : aliased Phil.Philosopher (My_ID => 3);
  Taft       : aliased Phil.Philosopher (My_ID => 4);
  Ichbiah    : aliased Phil.Philosopher (My_ID => 5);
 
  type Philosopher_Ptr is access all Phil.Philosopher;
 
  Phils      : array (Table_Type) of Philosopher_Ptr;
  Phil_Pics  : array (Table_Type) of Picture.Root_Ptr;
  Phil_Seats : array (Society.Unique_DNA_Codes) of Table_Type;
 
  task body Maitre_D is
 
    T          : Natural;
    Start_Time : Calendar.Time;
    Blanks     : constant String := "     ";
 
 
  begin
 
    accept Start_Serving;
 
    Start_Time := Calendar.Clock;
 
    -- now Maitre_D assigns phils to seats at the table
 
    Phils :=
      (Dijkstra'Access,
       Anderson'Access,
       Ichbiah'Access,
       Taft'Access,
       Stroustrup'Access);
 
    -- Which seat each phil occupies.
    for I in Table_Type loop
       Phil_Seats (Phils(I).My_Id) := I;
    end loop;
 
    Phil_Pics :=
       (new Picture.North, 
        new Picture.East, 
        new Picture.South,
        new Picture.South,
        new Picture.West);
 
    Picture.Open (Phil_Pics(1).all,( 1, 24), 7, 30);
    Picture.Open (Phil_Pics(2).all,( 9, 46), 7, 30);
    Picture.Open (Phil_Pics(3).all,(17, 41), 7, 30);
    Picture.Open (Phil_Pics(4).all,(17,  7), 7, 30);
    Picture.Open (Phil_Pics(5).all,( 9,  2), 7, 30);
 
 
    -- and assigns them their chopsticks.
 
    Phils (1).Start_Eating (1, 2);
    Phils (3).Start_Eating (3, 4);
    Phils (2).Start_Eating (2, 3);
    Phils (5).Start_Eating (1, 5);
    Phils (4).Start_Eating (4, 5);
 
    loop
      select
        accept Report_State (Which_Phil : in Society.Unique_DNA_Codes;
                             State      : in Phil.States;
                             How_Long   : in Natural := 0;
                             Which_Meal : in Natural := 0) do
 
          T := Natural (Calendar."-" (Calendar.Clock, Start_Time));
 
          case State is
 
            when Phil.Breathing =>
              Picture.Title (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     Society.Name_Register (Which_Phil));
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "Breathing...");
 
            when Phil.Thinking =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "Thinking" 
                      & Integer'Image (How_Long) & " seconds.");
 
            when Phil.Eating =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "Meal"  
                      & Integer'Image (Which_Meal)
                      & ","  
                      & Integer'Image (How_Long) & " seconds.");
 
            when Phil.Done_Eating =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "Yum-yum (burp)");
              Picture.Left_Fork (Phil_Pics (Phil_Seats (Which_Phil)).all, False);
              Picture.Right_Fork (Phil_Pics (Phil_Seats (Which_Phil)).all, False);
 
            when Phil.Got_Left_Stick =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "First chopstick" 
                      & Integer'Image (How_Long));
              Picture.Left_Fork (Phil_Pics (Phil_Seats (Which_Phil)).all, True);
 
            when Phil.Got_Right_Stick =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "First chopstick" 
                      & Integer'Image (How_Long));
              Picture.Right_Fork (Phil_Pics (Phil_Seats (Which_Phil)).all, True);
 
            when Phil.Got_Other_Stick =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "Second chopstick" 
                      & Integer'Image (How_Long));
              Picture.Left_Fork (Phil_Pics (Phil_Seats (Which_Phil)).all, True);
              Picture.Right_Fork (Phil_Pics (Phil_Seats (Which_Phil)).all, True);
 
            when Phil.Dying =>
              Picture.Put_line (Phil_Pics (Phil_Seats (Which_Phil)).all,
                     "T =" & Integer'Image (T) & " " 
                      & "Croak");
 
          end case; -- State
 
        end Report_State;
 
      or
        terminate;
      end select;
 
    end loop;
 
  end Maitre_D;
 
end Room;
 
--::::::::::
--diners.adb
--::::::::::
with Text_IO;
with Room;
procedure Diners is
 
  -- Dining Philosophers - Ada 95 edition
 
  -- This is the main program, responsible only for telling the
  --   Maitre_D to get busy.
 
  -- Michael B. Feldman, The George Washington University,
  -- July, 1995.
 
begin
  --Text_IO.New_Line;     -- artifice to flush output buffer
  Room.Maitre_D.Start_Serving;
end Diners;


This version of the Dining Philosophers example was provided by Dr. Michael B. Feldman of the George Washington University and Bjorn Kallberg of CelciusTech Systems, Sweden. This example was compiled using the GNAT Ada 95 compiler, version 2.07, on a Sun platform.


References