Ada 95 :: y11_pol1.ada


package Class_abstract_room is
  type A_Room   is abstract tagged null record;
  type P_A_Room is access all A_Room'Class;

  function  where( the:in A_Room ) return Positive is abstract;
  function  describe( the:in A_Room ) return String is abstract;
end Class_abstract_room;

with Class_abstract_room, Ada.Strings.Unbounded;
use  Class_abstract_room, Ada.Strings.Unbounded;
package Class_room is
  type Room   is new A_Room with private;
  type P_Room is access all Room'Class;

  procedure initialize( the:in out Room; no:in Positive;
                        mes:in String );
  function  build_room( no:in Positive;
                        desc:in String ) return P_A_Room;
  function  where( the:in Room ) return Positive;
  function  describe( the:in Room ) return String;
private
  type Room is new A_Room with record
     desc  : Unbounded_string;   -- Description of room
     number: Positive;           -- Room number
  end record;
end Class_room;

with Ada.Integer_Text_io;
use  Ada.Integer_Text_io;
package body Class_room is

  procedure initialize( the:in out Room;
                        no:in Positive; mes:in String ) is
  begin
    the.desc := to_unbounded_string( mes );
    the.number := no;
  end initialize;

  function  build_room( no:in Positive;
                        desc:in String ) return P_A_Room is
    p : P_Room;
  begin
    p := new Room; initialize( p.all, no, desc );
    return p.all'Access;
  end build_room;

  function  where( the:in Room ) return Positive is
  begin
    return the.number;
  end where;

  function  describe( the:in Room ) return String is
    num : String( 1 .. 4 );    -- Room number as string
  begin
    put( num, the.number );
    return num & " " & to_string(the.desc);
  end describe;

end Class_room;

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


with Class_abstract_room, Class_room;
use  Class_abstract_room, Class_room;
package Class_office is
  type Office is new Room with private;
  type P_Office is access all Office;

  procedure initialize( the:in out Office; no:in Positive;
                        desc:in String; people:in Natural );
  function  build_office( no:in Positive; desc:in String;
                          people:in Natural ) return P_A_Room;
  function  deliver_no_of_people(the:in Office) return Natural;
  function  describe( the:in Office ) return String;
private
  type Office is new Room with record
    people : Natural := 0;            -- Occupants
  end record;
end Class_office;


with Ada.Integer_Text_io, Ada.Text_io;
use  Ada.Integer_Text_io, Ada.Text_io;
package body Class_office is

  procedure initialize( the:in out Office; no:in Positive;
                        desc:in String; people:in Natural ) is
  begin
    initialize( the, no, desc );
    the.people := people;
  end initialize;

  function  build_office( no:in Positive; desc:in String;
                          people:in Natural ) return P_A_Room is
    p : P_Office;
  begin
    p := new Office; initialize( p.all, no, desc, people );
    return p.all'Access;
  end build_office;

  function deliver_no_of_people( the:in Office ) return Natural is
  begin
    return the.people;
  end deliver_no_of_people;

  function  describe( the:in Office ) return String is
    no : String( 1 .. 4 );    -- the.people as string
  begin
    put(  no, the.people );
    return describe( Room(the) ) &
           " occupied by" & no & " people";
  end describe;

end Class_office;

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

--package Class_room.build is
--  type P_Room is access all Room'Class;
--
--  function  build_room( no:in Positive;
--                        desc:in String ) return P_Room;
--end Class_room.build;
--
--package body Class_room.build is
--
--  function  build_room( no:in Positive;
--                        desc:in String ) return P_Room is
--    p : P_Room;
--  begin
--    p := new Room; initialize( p.all, no, desc );
--    return p;
--  end build_room;
--
--end Class_room.build;

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

--with Class_room, Class_room.build;
--use  Class_room, Class_room.build;
--package Class_office.build is
--
--  function  build_office( no:in Positive; desc:in String;
--                          people:in Natural ) return P_Room;
--end Class_office.build;
--
--
--package body Class_office.build is
--
--  type P_Office is access all Office;
--
--  function  build_office( no:in Positive; desc:in String;
--                          people:in Natural ) return P_Room is
--    p : P_Office;
--  begin
--    p := new Office; initialize( p.all, no, desc, people );
--    return p.all'Access;
--  end build_office;
--
--end Class_office.build;

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

--with Ada.Text_io, Class_room, Class_room.build;
--use  Ada.Text_io, Class_room, Class_room.build;
with Ada.Text_io, Class_abstract_room;
use  Ada.Text_io, Class_abstract_room;
package Class_building is

  type Building is tagged private;

  procedure add( the:in out Building; desc:in P_A_Room );
  function about(the:in Building; no:in Positive) return String;

private
  MAX_ROOMS : CONSTANT := 15;
  type    Rooms_index is range 0 .. MAX_ROOMS;
  subtype Rooms_range is Rooms_index range 1 .. MAX_ROOMS;
  type    Rooms_array is array (Rooms_range) of P_A_Room;

  type Building is tagged record
    last        : Rooms_index := 0;  -- Last slot allocated
    description : Rooms_array;       -- Rooms in building
  end record;
end Class_building;


package body Class_building is

  procedure add( the:in out Building; desc:in P_A_Room ) is
  begin
    if the.last < MAX_ROOMS then
      the.last := the.last + 1;
      the.description( the.last ) := desc;
    else
      raise Constraint_error;
    end if;
  end add;

  function about(the:in Building; no:in Positive) return String is
  begin
    for i in 1 .. the.last loop
      if where(the.description(i).all) = no then
        return describe(the.description(i).all);
      end if;
    end loop;
    return "Sorry room not known";
  end about;
end Class_building;

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

package Pack_procedures is
  procedure ex1;
  procedure ex2;
  procedure ex3;
  procedure ex4;
  procedure ex5;
  procedure ex6;
  procedure ex7;
  procedure ex8;
end Pack_procedures;

--with Ada.Integer_Text_io, Ada.Text_io,
--     Class_room, Class_room.build,
--     Class_office, Class_office.build, Class_building, Ada.Tags;
--use  Ada.Integer_Text_io, Ada.Text_io,
--     Class_room, Class_room.build,
--     Class_office, Class_office.build, Class_building, Ada.Tags;
with Ada.Integer_Text_io, Ada.Text_io,
     Class_abstract_room, Class_room, Class_office, Class_building, Ada.Tags;
use  Ada.Integer_Text_io, Ada.Text_io,
     Class_abstract_room, Class_room, Class_office, Class_building, Ada.Tags;
package body Pack_procedures is

procedure ex1 is
  w422 : Room;
  w414 : Office;
  procedure about( place:in Room'Class ) is
  begin
    put( "The place is" ); new_line;
    put( "  " & describe( place ) ) ;  -- Run time dispatch
    new_line;
  end about;
begin
  initialize( w414, 414, "4th Floor west wing", 2 );
  initialize( w422, 422, "4th Floor east wing" );

  about( w422 );                       -- Call with a room
  about( w414 );                       -- Call with an Office

end ex1;

procedure ex2 is
  w422: Room;
  w414: Office;
begin
  initialize( w414, 414, "4th Floor west wing", 2 );
  initialize( w422, 422, "4th Floor east wing" );

  --if w422'Tag = w414'Tag then
  if FALSE then
    put("Areas are the same type of accommodation");
    new_line;
  end if;
  --if w422'Tag /= w414'Tag then
  if TRUE then
    put("Areas are different type of accommodation");
    new_line;
  end if;
end ex2;

procedure ex3 is

procedure set_up( watts:in out Building ) is
begin
  add( watts, build_office( 414, "4th Floor west wing", 2 ) );
  add( watts, build_room  ( 422, "4th Floor east wing" ) );
end set_up;

procedure main is
  watts   : Building;                      -- Watts Building
  room_no : Positive;                      -- Queried room
begin
  set_up( watts );                         -- Populate building
  loop
    begin
      put( "Inquiry about room: " );       -- Ask
      exit when end_of_file;
      get( room_no ); skip_line;           -- User response
      put( about( watts, room_no ) );
      new_line;                            -- Display answer
    exception
      when Data_error =>
        put("Please retype the number");   -- Ask again
        new_line; skip_line;
    end;
  end loop;
end main;

begin
  main;
end ex3;

procedure ex4 is
begin
  null;
end ex4;

-- Downcasting

procedure ex5 is
  MAX_ROOMS : CONSTANT := 3;
  type    Rooms_index  is range 0 .. MAX_ROOMS;
  subtype Rooms_range  is Rooms_index range 1 .. MAX_ROOMS;
  type    Rooms_array  is array ( Rooms_range ) of P_A_Room;
  type    Office_array is array ( Rooms_range ) of Office;
  accommodation : Rooms_array;    -- Rooms and Offices
  offices       : Office_array;   -- Offices only
  no_offices    : Rooms_index;
begin
  accommodation(1):=build_office(414, "4th Floor west wing", 2);
  accommodation(2):=build_room  (518, "5th Floor east wing");
  accommodation(3):=build_office(403, "4th Floor east wing", 1);

  no_offices := 0;
  for i in Rooms_range loop
    if accommodation(i).all'Tag = Office'Tag then
      no_offices := no_offices + 1;
      offices(no_offices) := Office(accommodation(i).all);  --
    end if;
  end loop;

  put("The offices are:" ); new_line;
  for i in 1 .. no_offices loop
    put( describe( offices(i) ) ); new_line;
  end loop;

end ex5;

procedure ex6 is
  --MAX_ROOMS : CONSTANT := 2;
  --type P_Room is access all Room'Class;
  w422 : aliased Room;
  w414 : aliased Office;
begin
  return;
  initialize( w422, 422, "4th Floor east wing" );
  initialize( w414, 414, "4th Floor west wing", 2 );
  --put( Ada.Tags.external_tag( w422'Tag ) ); new_line;
  --put( Ada.Tags.expanded_name( w422'Tag ) ); new_line;
end ex6;

procedure ex7 is
  MAX_ROOMS : CONSTANT := 3;
  type    Rooms_index is range 0 .. MAX_ROOMS;
  subtype Rooms_range is Rooms_index range 1 .. MAX_ROOMS;
  type    Rooms_array is array ( Rooms_range ) of P_A_Room;
  accommodation : Rooms_array;
begin
  accommodation(1):=build_office(414, "4th Floor west wing", 2);
  accommodation(2):=build_room  (518, "5th Floor east wing");
  accommodation(3):=build_office(403, "4th Floor east wing", 1);
end ex7;

-- If only one componant in a record aggrigate then must be named
-- If more than one componant WITH
--  withdraws => 2, xx => 3 etc.

procedure ex8 is
  WITHDRAWALS_IN_A_WEEK : CONSTANT Natural := 3;
  subtype Money    is Float;
  type Account     is tagged record
     balance_of : Money := 0.00;      -- Amount in account
  end record;
  type Account_ltd is new Account with record
    withdrawals : Natural := WITHDRAWALS_IN_A_WEEK;
  end record;
  type Account_2 is new Account with null record;
  normal     : Account;
  restricted : Account_ltd;
  other      : Account_2;
begin
  normal     := ( balance_of => 20.0 );
  restricted := ( normal with 4 );
  restricted := ( normal with withdrawals => 4 );
  other      := ( normal with null record );
end ex8;

end Pack_procedures;

with Ada.Text_io, Pack_procedures;
use  Ada.Text_io, Pack_procedures;
procedure main is
begin
  put("Example 1"); new_line; ex1;
  put("Example 2"); new_line; ex2;
  put("Example 3"); new_line; ex3;
  put("Example 4"); new_line; ex4;
  put("Example 5"); new_line; ex5;
  put("Example 6"); new_line; ex6;
  put("Example 7"); new_line; ex7;
  put("Example 8"); new_line; ex8;
end main;


© M.A.Smith University of Brighton. Created September 1995 last modified May 1997.
Comments, suggestions, etc. M.A.Smith@brighton.ac.uk * [Home page]