-- body of generic package to represent preference information
-- for an instance of the stable roommates problem

-- author: Rob Irving, University of Glasgow
-- last modified: 31 August 2000

with Ada.Text_Io;
use Ada.Text_Io;
with Ada.Integer_Text_Io;
use Ada.Integer_Text_Io;
with Names;
use Names;
with Name_Table;

package body Rm_Pref_Info is

   package Table is new Name_Table(Num_Persons);
   use Table;

   Page_Width : constant Integer   := 80;  
   Blank      : constant Character := ' ';  
   Star       : constant Character := '*';  
   Colon      : constant Character := ':';  

   type Sequence_Type is array (Rank_Index) of Person_Index; 
   type Position_Type is array (Person_Index) of Rank_Index; 
   type Rotation_Type is 
      record 
         Sequence : Sequence_Type;  
         Position : Position_Type := (others => 0);  
         Start,  
         Finish   : Rank_Index    := 0;  
      end record; 

   ----------------------------------------------------------
   function First_Choice (
         P : in     Pref_Info_Type; 
         I :        Person_Index    ) 
     return Person_Index is 
      -- returns first person in I's current preference list
      Pos : Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P(I).Pref_List(0).Successor;
         return P(I).Pref_List(Pos).Person;
      end if;
   end First_Choice;
   ----------------------------------------------------------

   ----------------------------------------------------------
   function Second_Choice (
         P : in     Pref_Info_Type; 
         I :        Person_Index    ) 
     return Person_Index is 
      -- returns second person in I's current preference list;
      -- assumes at least two entries in the list
      Pos : Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P(I).Pref_List(0).Successor;
         Pos := P(I).Pref_List(Pos).Successor;
         return P(I).Pref_List(Pos).Person;
      end if;
   end Second_Choice;
   ----------------------------------------------------------

   ----------------------------------------------------------
   function Last_Choice (
         P : in     Pref_Info_Type; 
         I :        Person_Index    ) 
     return Person_Index is 
      -- returns last person in I's current preference list
      Pos : Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P(I).Pref_List(0).Predecessor;
         return P(I).Pref_List(Pos).Person;
      end if;
   end Last_Choice;
   ----------------------------------------------------------

   ----------------------------------------------------------
   function Successor_Person (
         P : in     Pref_Info_Type; 
         I,                         
         J :        Person_Index    ) 
     return Person_Index is 
      -- returns successor of J in I's current preference list
      Location : Rank_Index;  
   begin
      if I = 0 or J = 0 then
         return 0;
      else
         Location := P(I).Rank(J);
         Location := P(I).Pref_List(Location).Successor;
         return P(I).Pref_List(Location).Person;
      end if;
   end Successor_Person;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Remove (
         P : in out Pref_Info_Type; 
         I,                         
         J : in     Person_Index    ) is 
      -- removes the pair (I,J) from the preference structure 
      Location,  
      Previous,  
      Next     : Rank_Index;  
   begin
      if I /= 0 and J /= 0 then
         Location := P(I).Rank(J);
         if Location /= Num_Persons then
            Next := P(I).Pref_List(Location).Successor;
            Previous := P(I).Pref_List(Location).Predecessor;
            P(I).Pref_List(Next).Predecessor := Previous;
            P(I).Pref_List(Previous).Successor := Next;
            P(I).List_Length := P(I).List_Length - 1;
         end if;
         Location := P(J).Rank(I);
         if Location /= Num_Persons then
            Next := P(J).Pref_List(Location).Successor;
            Previous := P(J).Pref_List(Location).Predecessor;
            P(J).Pref_List(Next).Predecessor := Previous;
            P(J).Pref_List(Previous).Successor := Next;
            P(J).List_Length := P(J).List_Length - 1;
         end if;
      end if;
   end Remove;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Calculate_Ranks (
         P : in out Pref_Info_Type ) is 
      -- calculates the ranking arrays from the preference lists
   begin
      for I in Person_Index loop
         for J in Rank_Index loop
            if P(I).Pref_List(J).Person /= 0 then
               P(I).Rank(P(I).Pref_List(J).Person) := J;
            end if;
         end loop;
      end loop;
   end Calculate_Ranks;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Make_Lists_Consistent (
         P : in out Pref_Info_Type ) is 
      -- removes I from J's list whenever J is absent from I's
      J,  
      K : Person_Index;  
   begin
      for I in 1..Num_Persons loop
         J := First_Choice(P, I);
         while J /= 0 loop
            if P(J).Rank(I) = Num_Persons then
               K := Successor_Person(P, I, J);
               Remove(P, I, J);
               J := K;
            else
               J := Successor_Person(P, I, J);
            end if;
         end loop;
      end loop;
   end Make_Lists_Consistent;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Map_Name (
         N : in     Name_Type;   
         I :    out Person_Index ) is 
      -- returns in I the number of the person whose identifier is N
      -- inserting this pair in the table if not already present
   begin
      I := Look_Up(N);
      if I = 0 then
         if Table_Size < Num_Persons then
            Add(N);
            I := Table_Size;
         else
            raise Table_Overflow;
         end if;
      end if;
   end Map_Name;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Get_Pref_Info (
         P :    out Pref_Info_Type ) is 
      Name_1,  
      Name_2  : Name_Type;  
      Next,  
      Temp,  
      Count   : Person_Index := 0;  
      Ch      : Character;  
      Success : Boolean;  
      Ov      : Boolean      := False;  
   begin
      while not End_Of_File loop
         if End_Of_Line then
            Skip_Line;
         else
            Get_Name(Name_1, Ov, Success);
            Get(Ch); -- the space
            Get(Ch); -- the colon
            Map_Name(Name_1, Next);
            Count := Count + 1;
            Set_Required_Posn(Next, Count);
            P(Next).Pref_List(0).Predecessor := 0;
            for Pos in 1..Num_Persons loop
               if not End_Of_Line then
                  Get_Name(Name_2, Ov, Success);
                  if Success then
                     Map_Name(Name_2, Temp);
                     if Temp = Next then
                        raise Pref_List_Error;
                     end if;
                     P(Next).Pref_List(Pos).Person := Temp;
                     P(Next).Pref_List(Pos-1).Successor := Pos mod
                        Num_Persons;
                     P(Next).Pref_List(Pos).Predecessor := Pos - 1;
                     P(Next).List_Length := P(Next).List_Length + 1;
                  end if;
               else
                  P(Next).Pref_List(Pos).Person := 0;
                  P(Next).Pref_List(Pos-1).Successor := 0;
                  if P(Next).Pref_List(0).Predecessor = 0 then
                     P(Next).Pref_List(0).Predecessor := Pos - 1;
                  end if;
               end if;
            end loop;
            Skip_Line;
         end if;
      end loop;
      Set_All_Required_Posns;
      Calculate_Ranks(P);
      Make_Lists_Consistent(P);
      if Ov then
         New_Line(3);
         Put("WARNING: one or more names too long. Names more than ");
         Put(Max_Name_Length, Width => 1);
         Put(" characters are truncated");
         New_Line(3);
      end if;
   end Get_Pref_Info;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Check_Line (
         S : in     Natural; 
         C : in out Natural  ) is 
      -- checks whether a new line is necessary; C is current
      -- column and S is number of columns needed
   begin
      if C + S > Page_Width then
         C := S;
         New_Line;
         Set_Col(Positive_Count(S));
      end if;
   end Check_Line;
   ----------------------------------------------------------

   procedure Put_Lists(P : in Pref_Info_type; B : in Boolean) is
   -- outputs complete preference lists with annotation if B true
      Name : Name_Type;  
      M,  
      Cols : Natural;  
      I    : Person_Index;
   begin
      Get_Max_Name_Length(M);
      for K in 1 .. Num_Persons loop
         I := Get_True_Entry(K);
         Name := Look_Up(I);
         Put_Name(Name);
         Set_Col(Positive_Count(M+2));
         Put(Colon);
         Cols := M + 2;
         for J in 1 .. Num_Persons loop
            if P(I).Pref_List(J).Person /= 0 then
               Name := Look_Up(P(I).Pref_List(J).Person);
               Check_Line(M+3, Cols);
               for I in 1..M+1-Length(Name) loop
                  Put(Blank);
               end loop;
               Put_Name(Name);
               if B and then P(I).Pref_List(J).Person = First_Choice(P, I) then
                  Put(Star);
               else
                  Put(Blank);
               end if;
               Cols := Cols + M + 2;
            end if;
         end loop;
         New_Line;
      end loop;
   end Put_Lists;
   ----------------------------------------------------------
   
   ----------------------------------------------------------
   procedure Put_Complete_Pref_Lists (
         P : in     Pref_Info_Type ) is   
   begin
      Put_Lists(P, False);
   end Put_Complete_Pref_Lists;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Display_Stable_Matching (
         P : in     Pref_Info_Type ) is 
   begin
      Put_Lists(P, True);
   end Display_Stable_Matching;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure List_Stable_Matching (
         P : in     Pref_Info_Type ) is 
      J      : Person_Index;  
      Cols,  
      I      : Natural      := 0;  
      Name_I,  
      Name_J : Name_Type;  
   begin
      for K in 1..Num_Persons loop
         I := Get_True_Entry(K);
         Name_I := Look_Up(I);
         J := First_Choice(P, I);
         if J /= 0 then
            Name_J := Look_Up(J);
         end if;
         if J /= 0 and then Name_J > Name_I then
            if Cols + Length(Name_I) + Length(Name_J) + 3 > 80 then
               Cols := 0;
               New_Line;
            end if;
            Cols := Cols + Length(Name_I) + Length(Name_J) + 5;
            Put('(');
            Put_Name(Name_I);
            Put(',');
            Put_Name(Name_J);
            Put(")  ");
         end if;
      end loop;
   end List_Stable_Matching;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Put_Current_Pref_Lists (
         P : in     Pref_Info_Type ) is 
      Name : Name_Type;  
      J    : Person_Index;  
      M,  
      Cols,  
      I    : Natural;  
   begin
      Get_Max_Name_Length(M);
      for K in 1 .. Num_Persons loop
         I := Get_True_Entry(K);
         Name := Look_Up(I);
         Put_Name(Name);
         Set_Col(Positive_Count(M+2));
         Put(Colon);
         Cols := M + 2;
         J := First_Choice(P, I);
         while J /= 0 loop
            Name := Look_Up(J);
            Check_Line(M+3, Cols);
            for I in 1..M+2-Length(Name) loop
               Put(Blank);
            end loop;
            Put_Name(Name);
            Cols := Cols + M + 2;
            J := Successor_Person(P, I, J);
         end loop;
         New_Line;
      end loop;
   end Put_Current_Pref_Lists;
   ----------------------------------------------------------

   ----------------------------------------------------------
   function Num_Non_Empty_Lists (
         P : Pref_Info_Type ) 
     return Natural is 
      -- returns number of currently non-empty preference lists 
      Count : Natural := 0;  
   begin
      for I in 1..Num_Persons loop
         if P(I).List_Length > 0 then
            Count := Count + 1;
         end if;
      end loop;
      return Count;
   end Num_Non_Empty_Lists;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Apply_Phase_1 (
         P           : in out Pref_Info_Type; 
         Sm_Possible :    out Boolean         ) is 
      Proposer,  
      Next,  
      Next_Proposer,  
      Responder     : Person_Index;  
   begin
      for I in 1 .. Num_Persons loop
         Proposer := I;
         Responder := First_Choice(P, Proposer);
         while Proposer /= 0 and Responder /= 0 loop
            -- Put(Proposer, Width => 1);
            -- Put(" proposes to ");
            -- Put(Responder, Width => 1);
            -- New_Line;
            Next := Successor_Person(P, Responder, Proposer);
            if P(Responder).Holds_Proposal then
               Next_Proposer := Last_Choice(P, Responder);
            else
               Next_Proposer := 0;
               P(Responder).Holds_Proposal := True;
            end if;
            while Next /= 0 loop
               Remove(P, Next, Responder);
               Next := Successor_Person(P, Responder, Proposer);
            end loop;
            Proposer := Next_Proposer;
            Responder := First_Choice(P, Proposer);
         end loop;
      end loop;
      Sm_Possible := (Num_Non_Empty_Lists(P) mod 2) = 0;
   end Apply_Phase_1;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Find (
         P    : in     Pref_Info_Type; 
         F    : in out Person_Index;   
         Done : in out Boolean         ) is 
      -- updates F to be the first person with > 1 entry in his
      -- current preference list; returns Done = true if no such person
   begin
      while First_Choice(P, F) = Last_Choice(P, F) and not Done loop
         if F = Num_Persons then
            Done := True;
         else
            F := F + 1;
         end if;
      end loop;
   end Find;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Find_Rotation (
         P : in     Pref_Info_Type; 
         F : in     Person_Index;   
         R : in out Rotation_Type   ) is 
      -- returns in R a rotation exposed in the current preference
      -- lists; F is the first person with >= 2 entries in his list
      Pos  : Rank_Index;  
      Next,  
      X    : Person_Index;  
   begin
      if R.Start > 1 then
         Next := R.Sequence(R.Start-1);
         X := Second_Choice(P, Next);
         Next := Last_Choice(P, X);
         Pos := R.Start - 1;
      else
         Next := F;
         Pos := 0;
      end if;
      while R.Position(Next) = 0 loop
         Pos := Pos + 1;
         R.Sequence(Pos) := Next;
         R.Position(Next) := Pos;
         X := Second_Choice(P, Next);
         Next := Last_Choice(P, X);
      end loop;
      R.Start := R.Position(Next);
      R.Finish := Pos;
   end Find_Rotation;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Eliminate_Rotation (
         P           : in out Pref_Info_Type; 
         R           : in out Rotation_Type;  
         Sm_Possible : in out Boolean         ) is 
   -- eliminates the exposed rotation R from the current
   -- preference lists; returns SM_Possible = false if some 
   -- list becomes empty as a result
      X,  
      Y : Person_Index;
      Pos : Rank_Index;
      Backing_Up : Boolean := True;  
   begin
      for Pos in R.Start..R.Finish loop
         Y := R.Sequence(Pos);
         Remove(P, Y, First_Choice(P, Y));
      end loop;
      for Pos in R.Start..R.Finish loop
         Y := R.Sequence(Pos);
         X := First_Choice(P, Y);
         if X = 0 then
            Sm_Possible := False;
            exit;
         end if;
         while Successor_Person(P, X, Y) /= 0 loop
            Remove(P, X, Successor_Person(P, X, Y));
         end loop;
      end loop;
      for Pos in R.Start..R.Finish loop
         R.Position(R.Sequence(Pos)) := 0;
         R.Sequence(Pos) := 0;
      end loop;
      Pos := R.Start - 1;
      -- now check if entries on the 'tail' of the eliminated
      -- rotation have had their preference lists reduced to
      -- a single entry, in which case they cannot serve as
      -- the starting point for the next rotation search
      while Pos >= 1 and Backing_Up loop
         if P(R.Sequence(Pos)).List_Length = 1 then
            R.Position(R.Sequence(Pos)) := 0;
            R.Sequence(Pos) := 0;
            R.Start := R.Start - 1;
            Pos := Pos - 1;
         else
            Backing_Up := False;
         end if;
      end loop;
   end Eliminate_Rotation;
   ----------------------------------------------------------

   ----------------------------------------------------------
   procedure Apply_Phase_2 (
         P        : in out Pref_Info_Type; 
         Sm_Found :    out Boolean         ) is 
      Sm_Possible     : Boolean       := True;  
      First_Unmatched : Person_Index  := 1;  
      R               : Rotation_Type;  
   begin
      Sm_Found := False;
      while Sm_Possible and not Sm_Found loop
         Find(P, First_Unmatched, Sm_Found);
         if not Sm_Found then
            Find_Rotation(P, First_Unmatched, R);
            Eliminate_Rotation(P, R, Sm_Possible);
         end if;
      end loop;
   end Apply_Phase_2;
   ----------------------------------------------------------

end Rm_Pref_Info;