... this page is part of the Web Site of George North ...
Doublely_Linked_List_Pack
with Unchecked_Deallocation;
-- ======================================================================
-- Package: Circ_List_Pack
-- by George North
-- Fall 1994
-- Problem: Provide a generic circular doublely linked list.
generic
type Element_Type is private;
-- with function Equals( X : Element_Type;
-- Y : Element_Type ) return boolean;
package Circ_List_Pack is
type Position_Type is private;
type List is limited private;
-- ======================================================================
-- Function: Is_Empty
-- Precondition: valit List
-- Postcondition: true or false
function Is_Empty( L : List ) return boolean;
-- ======================================================================
-- Function: Find_Previous
-- Precondition: current position in list and valid list
-- Postcondition: position of previous node in list
function Find_Previous( P : Position_Type; L : List )
return Position_Type;
-- ======================================================================
-- Function: Retrieve
-- Precondition: current position in list and valid list
-- Postcondition: element from this position in list
function Retrieve( P : Position_Type; L : List ) return Element_Type;
-- ======================================================================
-- Procedure: Advance
-- Precondition: current position in list and valid list
-- Postcondition: positon of next node in list
procedure Advance( P: in out Position_Type;
L : in List );
-- ======================================================================
-- Procedure: Delete
-- Precondition: current position in list and valid list
-- Postcondition: 1 - node at current position removed from list
-- 2 - memory space returned
-- 3 - current position set to preveious node
procedure Delete( P: in out Position_Type;
L : in List );
-- ======================================================================
-- Procedure: Insert
-- Precondition: current position in list and valid list
-- Postcondition: 1 - new node created after current position
-- 2 - position set to new node
procedure Insert( E : in Element_Type;
P : in out Position_Type;
L : in List );
-- ======================================================================
-- Procedure: Make_Null
-- Precondition: valid list
-- Postcondition: empty list
procedure Make_Null( L : in out List );
-- ======================================================================
-- Function: First_Node
-- Precondition: valid list
-- Postcondition: position of head of list
function First_Node(L : List ) return Position_Type;
-- ======================================================================
-- ======================================================================
private
type Node_Type;
type Position_Type is access Node_Type;
type Node_Type is
record
Element : Element_Type;
Prior : Position_Type;
Next : Position_Type;
end record;
type List is new Position_Type;
end Circ_List_Pack;
-- ======================================================================
-- ======================================================================
package body Circ_List_Pack is
Head : Position_Type := null;
Tail : Position_Type := null;
Current : Position_Type := null;
-- ======================================================================
procedure Free is new
Unchecked_Deallocation( Node_Type, Position_Type );
-- ======================================================================
-- Function: Is_Empty
-- Precondition: valit List
-- Postcondition: true or false
function Is_Empty( L : List ) return boolean is
begin -- Is_Empty
return L.Next = null;
end Is_Empty;
-- ======================================================================
-- Function: Find_Previous
-- Precondition: current position in list and valid list
-- Postcondition: position of previous node in list
function Find_Previous( P : Position_Type; L : List )
return Position_Type is
begin -- Find_Previous
return P.Prior;
end Find_Previous;
-- ======================================================================
-- Function: Retrieve
-- Precondition: current position in list and valid list
-- Postcondition: element from this position in list
function Retrieve( P : Position_Type; L : List )
return Element_Type is
begin -- Retrieve
return P.Element;
end Retrieve;
-- ======================================================================
-- Procedure: Advance
-- Precondition: current position in list and valid list
-- Postcondition: positon of next node in list
procedure Advance( P: in out Position_Type;
L : in List ) is
begin -- Advance
P := P.Next;
end Advance;
-- ======================================================================
-- Procedure: Delete
-- Precondition: current position in list and valid list
-- Postcondition: 1 - node at current position removed from list
-- 2 - memory space returned
-- 3 - current position set to preveious node
procedure Delete( P: in out Position_Type;
L : in List ) is
begin -- Delete
P.Prior.Next := P.Next;
P.Next.Prior := P.Prior;
Free( P );
P := P.Prior;
end Delete;
-- ======================================================================
-- Procedure: Insert
-- Precondition: current position in list and valid list
-- Postcondition: 1 - new node created after current position
-- 2 - position set to new node
procedure Insert( E : in Element_Type;
P : in out Position_Type;
L : in List ) is
Q : List;
T : Position_Type := P.Next;
begin -- Insert
-- Make_Null( L => Q );
Q := new Node_Type;
-- P := Q;
end Insert;
-- ======================================================================
-- Procedure: Make_Null
-- Precondition: valid list
-- Postcondition: empty list
procedure Make_Null( L : in out List ) is
begin -- Insert
L := new Node_Type;
end Make_Null;
-- ======================================================================
-- Function: First_Node
-- Precondition: valid list
-- Postcondition: position of head of list
function First_Node(L : List ) return Position_Type is
begin -- First_Node
return Head;
end First_Node;
-- ======================================================================
end Circ_List_Pack;
-- ======================================================================
-- ======================================================================
Josepus Game
a driver program for doubly_linked_list_pack
with Text_IO; use Text_IO;
with My_Int_IO; use My_Int_IO;
with Circ_List_Pack;
-- ======================================================================
-- Program: Josephus
-- by George North
-- Fall 1994
-- Problem: the Hot Pototato game for 'n' players,
-- using a generic package for double linked list
-- ======================================================================
procedure Josephus is
-- variable used to redirect console input (FOR TESTING ONLY)
sampleData : Text_IO.File_Type;
-- make a Josephus player record
Name_Size : Integer := 6;
ID_Type_Max : Integer := 9999;
subtype ID_Type is integer range 0 .. ID_Type_Max;
subtype Name_Type is string( 1 .. Name_Size );
subtype Steps_Type is integer range 1 .. ID_Type_Max * 10;
type Player_Type is
record
ID : ID_Type;
Name : Name_Type;
end record;
-- instanciate a Josephus List from generic
package Josephus_List is
new Circ_List_Pack( Element_Object => Player_Type );
use Josephus_List;
Current_Josephus : Element_Pointer;
-- needed virables
anID : ID_Type;
aName : Name_Type;
goSteps : Steps_Type;
Winner : Player_Type;
-- ======================================================================
-- Procedure : Print_a_Line
-- Precondition : one valid player record
-- Postcondition : none
procedure Print_a_Line( aPlayer : in Player_Type ) is
begin -- Print_a_Line
put( aPlayer.ID, 4);
put( " " );
put( aPlayer.Name );
Text_IO.New_Line;
end Print_a_Line;
-- ======================================================================
-- Procedure : Josephus_Players
-- Precondition : none
-- Postcondition : current element
procedure Josephus_Players( Current_Player : out Element_Pointer ) is
aPlayer : Player_Type;
begin -- Josephus_Players
while not End_of_File loop
-- Inveriant: loop will terminate when end of file is reached
loop
-- Inveriant: loop will terminate when a valid ID and
-- name are input or when end of file is reached.
begin -- get a id and name
if End_of_File then
exit;
end if;
get ( Item => aPlayer.ID );
get ( Item => aPlayer.Name );
exit;
exception
when Others =>
Put( "Text ID error, record skipped" );
Text_IO.New_Line;
Text_IO.Skip_Line;
end;
end loop;
-- Asseration: one valid player record inputed
insert_element( element => aPlayer );
Print_a_Line( aPlayer => aPlayer );
end loop;
-- Asseration: list of Josephus Players inputed and printed
current_player := Return_Current_Element;
Text_IO.New_Line( 2 );
end Josephus_Players;
-- ======================================================================
-- Function : Get_the_Winner
-- Precondition : List of Players and number of Steps each turn
-- Postcondition : the Winner
-- Algorithm : recursive function Get_Winner is
-- if only one element left then
-- we have a winner
-- else
-- step through the list 'm' times
-- and remove that member from list
-- try getting the winner again
function Get_Winner( Steps : Steps_Type;
Current_Player : Element_Pointer )
return Player_Type is
First_Element : Element_Pointer;
Last_Element : Element_Pointer;
aLooser : Player_Type;
begin -- Get_Winner
-- if first and last element are same, we have a winner
First_Element := Return_First_Element;
Last_Element := Return_Last_Element;
if First_Element = Last_Element then
return Return_Current_Element;
else
-- Step thru list, print then delete the looser
for I in 1 .. Steps loop
if not current_next then
Set_First;
end if;
end loop;
aLooser := Return_Current_Element;
Print_a_Line( aPlayer => aLooser );
Delete_Element;
-- try getting a winner again ...
return Get_Winner( Steps => Steps,
Current_Player => Return_Current_Element );
end if;
end Get_Winner;
-- ======================================================================
-- ======================================================================
begin -- Josephus
-- Open sample data file, for testing ONLY
Text_IO.Open( File => sampleData, Mode => Text_IO.In_File,
Name => "Prog6_Sample.dat" );
Text_IO.Set_Input( File => sampleData );
-- initalize the list, get number of passes each turn, get all players
Initialize_List;
get( Item => goSteps );
put( "The Josephus Game ... the players are: " );
Text_IO.New_Line;
Josephus_Players( Current_Player => Current_Josephus );
-- ready to play, set up to print loosers
put( goSteps, 5 );
put( " steps each round, lets PLAY !!!" );
Text_IO.New_Line( 3 );
put( "Loosers (in order) are ..." );
Text_IO.New_Line;
-- print then delete loosers until we have a winner, print winner
Winner := Get_Winner( Steps => goSteps,
Current_Player => Current_Josephus );
Text_IO.New_Line;
put( "And the Winner is ... " );
Text_IO.New_Line;
Print_a_Line( aPlayer => Winner );
Text_IO.New_Line;
end Josephus;