|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 11264 (0x2c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, procedure Phl, seg_058165
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
-- UNIT: procedure PHL
-- FILES: phl.a
-- COMPILE: ada phl.a -M phl -o phl
-- PURPOSE: tasking test and demonstration
-- DESCRIPTION: The dining philosophers problem.
-- Usage: phl
-- .......................................................................... --
with Text_Io;
procedure Phl is
Print_Task_Starts : constant Boolean := True;
Term_Type : Character := '1';
subtype Seat is Integer range 0 .. 4;
task type Output is
entry Put_Cursor (S : Seat; At_Table, Eating : Boolean);
entry Put_Line (S : in String);
entry Put (S : in String);
entry Term_Type_Entry (X : in Character);
entry Clear_Screen;
end Output;
O : Output;
task type Dining_Room is
entry Allocate_Seat (S : out Seat);
entry Enter;
entry Leave;
end Dining_Room;
Dr : Dining_Room;
task type Fork is
entry Pick_Up;
entry Put_Down;
end Fork;
Cutlery : array (0 .. 4) of Fork;
task type Philosopher;
School : array (0 .. 4) of Philosopher;
task Rand_Delay is
entry Rand;
end Rand_Delay;
task body Output is
Term_Type : Character; -- '1' for vt100, '2' for f100
Clear_Sc : constant String := Ascii.Esc & '*';
use Text_Io;
Pnum : Character;
R_S : Seat;
R_At_Table, R_Eating : Boolean;
type Xy_Position is
record
X : Integer range 0 .. 79;
Y : Integer range 0 .. 23;
end record;
Eating_Coords : array (Seat) of Xy_Position :=
((28, 6), (25, 12), (36, 15), (46, 12), (44, 6));
Thinking_Coords : array (Seat) of Xy_Position :=
((20, 21), (30, 21), (40, 21), (50, 21), (60, 21));
procedure Put (Item : in String; Pos : in Xy_Position) is
Xp : Integer := Pos.X;
Yp : Integer := Pos.Y;
Elp : Integer;
type As is access String;
S : As := new String'(Item);
Xs : As := new String'(Integer'Image (Xp));
Ys : As := new String'(Integer'Image (Yp));
begin
if Yp /= 23 then
Elp := 79;
else
Elp := 78;
end if; -- can't write 79,23
if (Xp + S'Length > Elp) then
S := new String'(S (S'First .. S'First + Elp - Xp));
end if;
-- position and write string
if Term_Type = '1' then
Text_Io.Put (Ascii.Esc & "[" & Ys (2 .. Ys'Last) &
";" & Xs (2 .. Xs'Last) & "H" & S.all);
else
Text_Io.Put (Ascii.Esc & "=" & Character'Val (32 + Yp) &
Character'Val (32 + Xp) & S.all);
end if;
end Put;
begin
accept Term_Type_Entry (X : in Character) do
Term_Type := X;
end Term_Type_Entry;
loop
select
accept Put_Cursor (S : Seat; At_Table, Eating : Boolean) do
R_S := S;
R_At_Table := At_Table;
R_Eating := Eating;
Pnum := Character'Val (R_S + 1 + Character'Pos ('0'));
if R_At_Table then
Put (" ", Thinking_Coords (R_S));
if R_Eating then
Put ("P" & Pnum & "E", Eating_Coords (R_S));
else
Put ("P" & Pnum & " ", Eating_Coords (R_S));
end if;
else
Put (" ", Eating_Coords (R_S));
Put ("P" & Pnum, Thinking_Coords (R_S));
end if;
end Put_Cursor;
or
accept Put (S : in String) do
Text_Io.Put (S);
end Put;
or
accept Put_Line (S : in String) do
Text_Io.Put_Line (S);
end Put_Line;
or
accept Clear_Screen do
if Term_Type = '1' then
Text_Io.Put (Ascii.Esc & "[2J" & Ascii.Esc & "[H");
else
Text_Io.Put (Clear_Sc);
end if;
delay 0.1;
end Clear_Screen;
end select;
end loop;
end Output;
task body Dining_Room is
Seats_Filled : Integer range 0 .. 5 := 0;
Seat_Allocation : Seat := 0;
begin
if Print_Task_Starts then
O.Put_Line ("dining room starting");
end if;
O.Clear_Screen;
O.Put_Line (" non_stop eating and thinking!");
O.Put_Line (" ");
O.Put_Line (" ");
O.Put_Line (" ");
O.Put_Line (" ***");
O.Put_Line (" *******");
O.Put_Line (" ***********");
O.Put_Line (" **O*** ******");
O.Put_Line (" ****** @@@ ***O**");
O.Put_Line (" ***** @@@@@ *****");
O.Put_Line (" ***** @@@ *****");
O.Put_Line (" **O** **O**");
O.Put_Line (" ******O******");
O.Put_Line (" ***********");
O.Put_Line (" ");
O.Put_Line (" ");
loop
select
--allocate fixed seat numbers to each of the five philosophers
accept Allocate_Seat (S : out Seat) do
S := Seat_Allocation;
if Seat_Allocation < 4 then
Seat_Allocation := Seat_Allocation + 1;
end if;
end Allocate_Seat;
or
when Seats_Filled < 5 =>
accept Enter do
Seats_Filled := Seats_Filled + 1;
end Enter;
or
accept Leave do
Seats_Filled := Seats_Filled - 1;
end Leave;
end select;
end loop;
end Dining_Room;
task body Fork is
begin
if Print_Task_Starts then
O.Put_Line ("fork starting");
end if;
loop
accept Pick_Up;
accept Put_Down;
end loop;
end Fork;
task body Rand_Delay is
Random : Duration := 0.4;
begin
loop
Random := Random + 0.05;
if Random > 0.7 then
Random := 0.4;
end if;
accept Rand do
delay Random;
end Rand;
end loop;
end Rand_Delay;
task body Philosopher is
S : Seat;
begin
if Print_Task_Starts then
O.Put_Line ("philosopher starting");
end if;
Dr.Allocate_Seat (S); --obtain seat on joining institution;
Dr.Enter;
O.Put_Cursor (S, At_Table => True, Eating => False);
Rand_Delay.Rand;
loop
Cutlery (S).Pick_Up;
select
Cutlery ((S + 1) mod 5).Pick_Up; --obtained two forks;
-- philosopher begins to eat
O.Put_Cursor (S, At_Table => True, Eating => True);
delay 1.0;
Cutlery ((S + 1) mod 5).Put_Down;
Cutlery (S).Put_Down;
--leave the room to think
Dr.Leave;
O.Put_Cursor (S, At_Table => False, Eating => False);
delay 1.2;
-- enter dining room again
Dr.Enter;
O.Put_Cursor (S, At_Table => True, Eating => False);
delay 0.9;
or
-- let someone else try for 2 forks
delay 0.9;
Cutlery (S).Put_Down;
Rand_Delay.Rand;
end select;
end loop;
end Philosopher;
begin
Text_Io.Put ("is this a vt100 (1) or an f100 (2) -->");
Text_Io.Get (Term_Type);
if Term_Type /= '1' and Term_Type /= '2' then
Text_Io.Put ("that's not a 1 or a 2, i'll assume you have a vt100");
end if;
O.Term_Type_Entry (Term_Type);
end Phl;
pragma Main;
-- .......................................................................... --
--
-- DISTRIBUTION AND COPYRIGHT:
--
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
--
-- DISCLAIMER:
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
nblk1=a
nid=0
hdr6=14
[0x00] rec0=27 rec1=00 rec2=01 rec3=026
[0x01] rec0=24 rec1=00 rec2=0a rec3=044
[0x02] rec0=1e rec1=00 rec2=09 rec3=006
[0x03] rec0=18 rec1=00 rec2=08 rec3=012
[0x04] rec0=21 rec1=00 rec2=07 rec3=05e
[0x05] rec0=15 rec1=00 rec2=06 rec3=01e
[0x06] rec0=23 rec1=00 rec2=05 rec3=008
[0x07] rec0=21 rec1=00 rec2=04 rec3=028
[0x08] rec0=20 rec1=00 rec2=03 rec3=006
[0x09] rec0=16 rec1=00 rec2=02 rec3=000
tail 0x21765743c87e0557e5c39 0x42a00088462060003