::
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]