-- Body of generic package to represent preference information
-- for an instance of the stable marriage problem

-- Author: Rob Irving, University of Glasgow
-- Last modified: 5 September 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 SM_Pref_Info is

   package Man_Table is new Name_Table(Num_Men);

   package Woman_Table is new Name_Table(Num_Women);
   
   type Annotation_Type is (Man, Woman, None);

   Page_Width : constant Integer := 80;
   Blank : constant Character := ' ';
   Star : constant Character := '*';
   Colon : constant Character := ':';
   
   --------------------------------------------------------
   function Man_First_Choice (
         P : in     Pref_Info_Type; 
         I :        Man_Index    ) 
      return Woman_Index is 
   -- returns first Woman in I's current preference list
      Pos : Woman_Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P.Men(I).Pref_List(0).Successor;
         return P.Men(I).Pref_List(Pos).Woman;
      end if;
   end Man_First_Choice;
   --------------------------------------------------------
   
   --------------------------------------------------------
   function Man_Last_Choice (
         P : in     Pref_Info_Type; 
         I :        Man_Index    ) 
      return Woman_Index is 
   -- returns last Woman in I's current preference list
      Pos : Woman_Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P.Men(I).Pref_List(0).Predecessor;
         return P.Men(I).Pref_List(Pos).Woman;
      end if;
   end Man_Last_Choice;
   --------------------------------------------------------

   --------------------------------------------------------   
   function Woman_First_Choice (
         P : in     Pref_Info_Type; 
         I :        Woman_Index    ) 
      return Man_Index is 
   -- returns first Man in I's current preference list
      Pos : Man_Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P.Women(I).Pref_List(0).Successor;
         return P.Women(I).Pref_List(Pos).Man;
      end if;
   end Woman_First_Choice;
   --------------------------------------------------------

   --------------------------------------------------------   
   function Woman_Last_Choice (
         P : in     Pref_Info_Type; 
         I :        Woman_Index    ) 
      return Man_Index is 
   -- returns last Man in I's current preference list
      Pos : Man_Rank_Index;  
   begin
      if I = 0 then
         return 0;
      else
         Pos := P.Women(I).Pref_List(0).Predecessor;
         return P.Women(I).Pref_List(Pos).Man;
      end if;
   end Woman_Last_Choice;
   --------------------------------------------------------

   --------------------------------------------------------
   function Successor_Woman (
         P :        Pref_Info_Type; 
         I :        Man_Index;                        
         J :        Woman_Index    ) 
      return Woman_Index is 
   -- returns the successor of Woman J in Man 
   -- I's current preference list
      Location : Woman_Rank_Index;  
   begin
      if I = 0 or J = 0 then
         return 0;
      else
         Location := P.Men(I).Rank(J);
         Location := P.Men(I).Pref_List(Location).Successor;
         return P.Men(I).Pref_List(Location).Woman;
      end if;
   end Successor_Woman;
   --------------------------------------------------------

   --------------------------------------------------------   
   function Successor_Man (
         P :        Pref_Info_Type; 
         I :        Woman_Index;                        
         J :        Man_Index    ) 
      return Man_Index is 
   -- returns the successor of Man J in Woman
   -- I's current preference list
      Location : Man_Rank_Index;  
   begin
      if I = 0 or J = 0 then
         return 0;
      else
         Location := P.Women(I).Rank(J);
         Location := P.Women(I).Pref_List(Location).Successor;
         return P.Women(I).Pref_List(Location).Man;
      end if;
   end Successor_Man;
   --------------------------------------------------------

   --------------------------------------------------------   
   function Predecessor_Man (
         P :        Pref_Info_Type; 
         I :        Woman_Index;                        
         J :        Man_Index    ) 
      return Man_Index is 
   -- returns the predecessor of Man J in Woman
   -- I's current preference list
      Location : Man_Rank_Index;  
   begin
      if I = 0 or J = 0 then
         return 0;
      else
         Location := P.Women(I).Rank(J);
         Location := P.Women(I).Pref_List(Location).Predecessor;
         return P.Women(I).Pref_List(Location).Man;
      end if;
   end Predecessor_Man;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Remove (
         P : in out Pref_Info_Type; 
         I : in     Man_Index;                        
         J : in     Woman_Index    ) is
   -- removes the pair (I,J) from the preference structure 
      W_Location,  
      W_Previous,  
      W_Next     : Woman_Rank_Index; 
      M_Location,  
      M_Previous,  
      M_Next     : Man_Rank_Index; 
   begin
      if I /= 0 and J /= 0 then
         W_Location := P.Men(I).Rank(J);
         if W_Location /= Num_Women+1 then
            W_Next := P.Men(I).Pref_List(W_Location).Successor;
            W_Previous := P.Men(I).Pref_List(W_Location).Predecessor;
            P.Men(I).Pref_List(W_Next).Predecessor := W_Previous;
            P.Men(I).Pref_List(W_Previous).Successor := W_Next;
            P.Men(I).List_Length := P.Men(I).List_Length - 1;
         end if;
         M_Location := P.Women(J).Rank(I);
         if M_Location /= Num_Men+1 then
            M_Next := P.Women(J).Pref_List(M_Location).Successor;
            M_Previous := P.Women(J).Pref_List(M_Location).Predecessor;
            P.Women(J).Pref_List(M_Next).Predecessor := M_Previous;
            P.Women(J).Pref_List(M_Previous).Successor := M_Next;
            P.Women(J).List_Length := P.Women(J).List_Length - 1;
         end if;
      end if;
   end Remove;
   --------------------------------------------------------

   --------------------------------------------------------   
   procedure Calculate_Man_Ranks (
         P : in out Pref_Info_Type ) is 
   -- calculates Man ranking arrays from preference lists
      H : Woman_Index;
   begin
      for I in 1..Num_Men loop
         for J in 1..Num_Women loop
            H := P.Men(I).Pref_List(J).Woman;
            if H /= 0 then
               P.Men(I).Rank(H) := J;
            end if;
         end loop;
      end loop;
   end Calculate_Man_Ranks;
   --------------------------------------------------------

   --------------------------------------------------------  
   procedure Calculate_Woman_Ranks (
         P : in out Pref_Info_Type ) is 
   -- calculates  Woman ranking arrays from preference lists
      R : Man_Index;
   begin
      for I in 1..Num_Women loop
         for J in 1..Num_Men loop
            R := P.Women(I).Pref_List(J).Man;
            if R /= 0 then
               P.Women(I).Rank(R) := J;
            end if;
         end loop;
      end loop;
   end Calculate_Woman_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 : Woman_Index; 
      L, M : Man_Index; 
   begin
      for I in 1..Num_Men loop
         J := Man_First_Choice(P, I);
         while J /= 0 loop
            if P.Women(J).Rank(I) = Num_Men+1 then
               K := Successor_Woman(P, I, J);
               Remove(P, I, J);
               J := K;
            else
               J := Successor_Woman(P, I, J);
            end if;
         end loop;
      end loop;
      for I in 1..Num_Women loop
         L := Woman_First_Choice(P, I);
         while L /= 0 loop
            if P.Men(L).Rank(I) = Num_Women+1 then
               M := Successor_Man(P, I, L);
               Remove(P, L, I);
               L := M;
            else
               L := Successor_Man(P, I, L);
            end if;
         end loop;
      end loop;
   end Make_Lists_Consistent;  
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Map_Man_Name (
         N : in     Name_Type;   
         I :    out Man_Index ) is 
   -- returns in I number of Man whose identifier is N
   -- inserting this pair in the table if not already present
   begin
      I := Man_Table.Look_Up(N);
      if I = 0 then
         if Man_Table.Table_Size < Num_Men then
            Man_Table.Add(N);
            I := Man_Table.Table_Size;
         else
                  Put_Name(N);
         Put(" caused table overflow"); New_Line;
            raise Table_Overflow;
         end if;
      end if;
   end Map_Man_Name;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Map_Woman_Name (
         N : in     Name_Type;   
         I :    out Woman_Index ) is 
   -- returns in I number of Woman whose identifier is N
   -- inserting this pair in the table if not already present
   begin
      I := Woman_Table.Look_Up(N);
      if I = 0 then
         if Woman_Table.Table_Size < Num_Women then
            Woman_Table.Add(N);
            I := Woman_Table.Table_Size;
         else
         Put_Name(N);
         Put(" caused table overflow"); New_Line;
            raise Table_Overflow;
         end if;
      end if;
   end Map_Woman_Name;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Get_Colon is
   -- discards input characters up to next colon
     Colon : constant Character := ':';
     Ch : Character;
   begin
     loop
       Get(Ch);
       exit when Ch = Colon;
     end loop;
   end Get_Colon;
   --------------------------------------------------------
  
   --------------------------------------------------------
   procedure Get_Pref_Info(P : out Pref_Info_Type) is
      Man_Name, Woman_Name  : Name_Type; 
      M_Next      : Man_Index; 
      W_Next      : Woman_Index; 
      M_Temp, M_Count     : Man_Index := 0;
      W_Temp, W_Count     : Woman_Index := 0;
      Success : Boolean;  
      Ov      : Boolean      := False; 
   begin
      for I in 1 .. Num_Men loop
         if End_Of_Line then
            Skip_Line;
         else
            Get_Name(Man_Name, Ov, Success);
            Get_Colon;
            Map_Man_Name(Man_Name, M_Next);
            M_Count := M_Count + 1;
            Man_Table.Set_Required_Posn(M_Next, M_Count);
            P.Men(M_Next).Pref_List(0).Predecessor := 0;
            for Pos in 1..Num_Women+1 loop
               if not End_Of_Line then
                  Get_Name(Woman_Name, Ov, Success);
                  if Success then
                     Map_Woman_Name(Woman_Name, W_Temp);
                     P.Men(M_Next).Pref_List(Pos).Woman := W_Temp;
                     P.Men(M_Next).Pref_List(Pos-1).Successor 
                                        := Pos mod (Num_Women+1);
                     P.Men(M_Next).Pref_List(Pos).Predecessor := Pos - 1;
                     P.Men(M_Next).List_Length := P.Men(M_Next).List_Length + 1;
                  end if;
               else
                  P.Men(M_Next).Pref_List(Pos-1).Successor := 0;
                  if P.Men(M_Next).Pref_List(0).Predecessor = 0 then
                     P.Men(M_Next).Pref_List(0).Predecessor := Pos - 1;
                  end if;
                  exit;
               end if;
            end loop;
            Skip_Line;
         end if;
      end loop;
      for I in 1 .. Num_Women loop
         if End_Of_Line then
            Skip_Line;
         else
            Get_Name(Woman_Name, Ov, Success);
            Get_Colon;
            Map_Woman_Name(Woman_Name, W_Next);
            W_Count := W_Count + 1;
            Woman_Table.Set_Required_Posn(W_Next, W_Count);
            P.Women(W_Next).Pref_List(0).Predecessor := 0;
            for Pos in 1..Num_Men+1 loop
               if not End_Of_Line then
                  Get_Name(Man_Name, Ov, Success);
                  if Success then
                     Map_Man_Name(Man_Name, M_Temp);
                     P.Women(W_Next).Pref_List(Pos).Man := M_Temp;
                     P.Women(W_Next).Pref_List(Pos-1).Successor 
                                        := Pos mod (Num_Men+1);
                     P.Women(W_Next).Pref_List(Pos).Predecessor := Pos - 1;
                     P.Women(W_Next).List_Length := P.Women(W_Next).List_Length + 1;
                  end if;
               else
                  P.Women(W_Next).Pref_List(Pos-1).Successor := 0;
                  if P.Women(W_Next).Pref_List(0).Predecessor = 0 then
                     P.Women(W_Next).Pref_List(0).Predecessor := Pos - 1;
                  end if;
                  exit;
               end if;
            end loop;
            Skip_Line;
         end if;
      end loop;
      Man_Table.Set_All_Required_Posns;
      Woman_Table.Set_All_Required_Posns;
      Calculate_Man_Ranks(P);
      Calculate_Woman_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; I : in Natural) is
   -- checks whether a new line is necessary; C is current
   -- column, S is number of columns needed, and I is the indentation
   -- on any new line
   begin
      if C + S > Page_Width then
         C := I;
         New_Line;
         Set_Col(Positive_Count(I));
      end if;
   end Check_Line;
   --------------------------------------------------------

   --------------------------------------------------------   
   procedure Put_Lists(P : in Pref_Info_Type; A : in Annotation_Type) is
      Name : Name_Type;  
      M, MR, MH, Cols : Natural;
      R : Natural; --Man_Index;
      H : Woman_Index;
   begin
      Man_Table.Get_Max_Name_Length(MR);
      Woman_Table.Get_Max_Name_Length(MH);
      if MH > MR then
         M := MH;
      else
         M := MR;
      end if;
      New_Line;
      Put("Men's Preferences");
      New_Line(2);
      for K in 1 .. Num_Men loop
         R := Man_Table.Get_True_Entry(K);
         Name := Man_Table.Look_Up(R);
         Put_Name(Name);
         Set_Col(Positive_Count(M+2));
         Put(Colon);
         Cols := M + 2;
         for J in 1 .. Num_Women loop
            if P.Men(R).Pref_List(J).Woman /= 0 then
               H := P.Men(R).Pref_List(J).Woman;
               Name := Woman_Table.Look_Up(H);
               Check_Line(M+3, Cols, M+3);
               for L in 1..M+2-Length(Name) loop
                  Put(Blank);
               end loop;
               Put_Name(Name);
               if (A = Man and H = Man_First_Choice(P, R)) or
                  (A = Woman and H = Man_Last_Choice(P, R)) then
                  Put(Star);
               else
                  Put(Blank);
               end if;
               Cols := Cols + M + 3;
            end if;
         end loop;
         New_Line;
      end loop;
      New_Line;
      Put("Women's Preferences");
      New_Line(2);
      for K in 1 .. Num_Women loop
         H := Woman_Table.Get_True_Entry(K);
         Name := Woman_Table.Look_Up(H);
         Put_Name(Name);
         Set_Col(Positive_Count(M+2));
         Put(Colon);
         Cols := M + 2;
         for J in 1 .. Num_Men loop
            R := P.Women(H).Pref_List(J).Man;
            if R /= 0 then
               Name := Man_Table.Look_Up(R);
               Check_Line(M+3, Cols, M+3);
               for L in 1..M+2-Length(Name) loop
                  Put(Blank);
               end loop;
               Put_Name(Name);
               if (A = Man and H = Man_First_Choice(P, R)) or
                  (A = Woman and H = Man_Last_Choice(P, R)) then
                  Put(Star);
               else
                  Put(Blank);
               end if;
               Cols := Cols + M + 3;
            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, None);
   end Put_Complete_Pref_Lists;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure List_M_Opt_Matching(P : in Pref_Info_Type) is
      H      : Woman_Index;  
      Cols, I   : Natural      := 0;  
      Name_I,  
      Name_W : Name_Type;  
   begin
      for K in 1..Num_Men loop
         I := Man_Table.Get_True_Entry(K);
         Name_I := Man_Table.Look_Up(I);
         H := Man_First_Choice(P, I);
         if H /= 0 then
            Name_W := Woman_Table.Look_Up(H);
         else
            Name_W := Blank_Name;
         end if;
         if Cols + Length(Name_I) + Length(Name_W) + 3 > 80 then
            Cols := 0;
            New_Line;
         end if;
         Cols := Cols + Length(Name_I) + Length(Name_W) + 5;
         Put('(');
         Put_Name(Name_I);
         Put(',');
         Put_Name(Name_W);
         Put(")  ");
      end loop;
      
      -- to be inserted: listing the matching Woman by Woman
   end List_M_Opt_Matching;
   --------------------------------------------------------

   --------------------------------------------------------   
   procedure List_W_Opt_Matching(P : in Pref_Info_Type) is
     H      : Woman_Index;  
      Cols, I   : Natural      := 0;  
      Name_I,  
      Name_W : Name_Type;  
   begin
   
       -- to be inserted: listing the matching Woman by Woman
        
      for K in 1..Num_Men loop
         I := Man_Table.Get_True_Entry(K);
         Name_I := Man_Table.Look_Up(I);
         H := Man_Last_Choice(P, I);
         if H /= 0 then
            Name_W := Woman_Table.Look_Up(H);
         else
            Name_W := Blank_Name;
         end if;
         if Cols + Length(Name_I) + Length(Name_W) + 3 > 80 then
            Cols := 0;
            New_Line;
         end if;
         Cols := Cols + Length(Name_I) + Length(Name_W) + 5;
         Put('(');
         Put_Name(Name_I);
         Put(',');
         Put_Name(Name_W);
         Put(")  ");
      end loop;
   end List_W_Opt_Matching;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Display_M_Opt_Matching(P : in Pref_Info_Type) is
   begin
      Put_Lists(P, Man);
   end Display_M_Opt_Matching;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Display_W_Opt_Matching(P : in Pref_Info_Type) is
   begin
      Put_Lists(P, Woman);
   end Display_W_Opt_Matching;
   --------------------------------------------------------

   --------------------------------------------------------   
   procedure Put_Current_Pref_Lists(P : in Pref_Info_Type) is
      Name : Name_Type;  
      H    : Woman_Index;
      R    : Man_Index;  
      M, MR, MH, Cols, I : Natural;
   begin
      Man_Table.Get_Max_Name_Length(MR);
      Woman_Table.Get_Max_Name_Length(MH);
      if MH > MR then
         M := MH;
      else
         M := MR;
      end if;
      for K in 1 .. Num_Men loop
         I := Man_Table.Get_True_Entry(K);
         Name := Man_Table.Look_Up(I);
         Put_Name(Name);
         Set_Col(Positive_Count(M+2));
         Put(Colon);
         Cols := M + 2;
         H := Man_First_Choice(P, I);
         while H /= 0 loop
            Name := Woman_Table.Look_Up(H);
            Check_Line(M+3, Cols, M+3);
            for I in 1..M+2-Length(Name) loop
               Put(Blank);
            end loop;
            Put_Name(Name);
            Cols := Cols + M + 2;
            H := Successor_Woman(P, I, H);
         end loop;
         New_Line;
      end loop;
      New_Line(2);
      for K in 1 .. Num_Women loop
         I := Woman_Table.Get_True_Entry(K);
         Name := Woman_Table.Look_Up(I);
         Put_Name(Name);
         Set_Col(Positive_Count(M+2));
         R := Woman_First_Choice(P, I);
         Put(Colon);
         Cols := M + 2;
         while R /= 0 loop
            Name := Man_Table.Look_Up(R);
            Check_Line(M+3, Cols, M+3);
            for I in 1..M+2-Length(Name) loop
               Put(Blank);
            end loop;
            Put_Name(Name);
            Cols := Cols + M + 2;
            R := Successor_Man(P, I, R);
         end loop;
         New_Line;
      end loop;
   end Put_Current_Pref_Lists;
   --------------------------------------------------------

   --------------------------------------------------------
   procedure Apply_GS_M(P : in out Pref_Info_Type) is
      Proposer, Next_Proposer, Next : Man_Index; 
      Responder     : Woman_Index;  
   begin
      for I in 1 .. Num_Men loop
         Proposer := I;
         Responder := Man_First_Choice(P, I);
         while Responder /= 0 and Proposer /= 0 loop
--            Put_Name(Man_Table.Look_Up(Proposer));
--            Put(" proposes to ");
--            Put_Name(Woman_Table.Look_Up(Responder));
--            New_Line;
            Next := Successor_Man(P, Responder, Proposer);
            if P.Women(Responder).Assigned then
               Next_Proposer := Woman_Last_Choice(P, Responder);
            else
               Next_Proposer := 0;
               P.Women(Responder).Assigned := True;
            end if;
            while Next /= 0 loop
               Remove(P, Next, Responder);
--               Put_Name(Man_Table.Look_Up(Next)); Put(' ');
--               Put_Name(Woman_Table.Look_Up(Responder));
--               Put(" removed");
--               New_Line;
               Next := Successor_Man(P, Responder, Proposer);
            end loop;
            Proposer := Next_Proposer;
            Responder := Man_First_Choice(P, Proposer);
         end loop;
      end loop;
   end Apply_GS_M;
   --------------------------------------------------------

   --------------------------------------------------------   
   procedure Apply_GS_W(P : in out Pref_Info_Type) is
      Proposer, Next_Proposer, Next : Woman_Index; 
      Responder     : Man_Index;  
      
   begin
      for I in 1 .. Num_Women loop
         Proposer := I;
         Responder := Woman_First_Choice(P, I);
         while Responder /= 0 and Proposer /= 0 loop
--            Put_Name(Woman_Table.Look_Up(Proposer));
--            Put(" proposes to ");
--            Put_Name(Man_Table.Look_Up(Responder));
--            New_Line;
            Next := Successor_Woman(P, Responder, Proposer);
            if P.Men(Responder).Assigned then
               Next_Proposer := Man_Last_Choice(P, Responder);
            else
               Next_Proposer := 0;
               P.Men(Responder).Assigned := True;
            end if;
            while Next /= 0 loop
               Remove(P, Responder, Next);
--               Put_Name(Woman_Table.Look_Up(Next)); Put(' ');
--               Put_Name(Man_Table.Look_Up(Responder));
--               Put(" removed");
--               New_Line;
               Next := Successor_Woman(P, Responder, Proposer);
            end loop;
            Proposer := Next_Proposer;
            Responder := Woman_First_Choice(P, Proposer);
         end loop;
      end loop;

   end Apply_GS_W;
   --------------------------------------------------------   

end SM_Pref_Info;