path: root/src/election.adb

with

    Ada.Strings.Fixed,
    Ada.Strings.Unbounded,
    Ada.Text_IO,
    Rationals;

use

    Ada.Text_IO;

use type

    Rationals.Fraction;


package body Election is


    package SU renames Ada.Strings.Unbounded;




    --  Candidate, preference data, and other information
    --  that's actively used by the main STV algorithm.
    Pref_Data  : Bundle_Containers.Bundle_Map;
    Cand_Data  : Candidates.Containers.Candidate_Map;
    Entries    : Entry_Vectors.Vector;
    Exhausted  : Extra_Data;
    Fractional : Extra_Data;
    Transfers  : Transfer_Vectors.Vector;


    --  Logging settings.
    Out_Dir      : SU.Unbounded_String;
    Next_Log_Num : Positive;
    Main_Log     : File_Type;


    --  Static info about the election.
    --  (Although Vacancies gets modified as seats are won.)
    Seats        : Natural;
    Vacancies    : Natural;
    Total_Papers : Natural;
    Quota        : Natural;


    --  Administrative details of the program.
    Verbose    : Boolean;
    Work_To_Do : Boolean := False;




    function Droop_Quota
           (Votes : in Natural;
            Seats : in Natural)
        return Natural is
    begin
        return Votes / (Seats + 1) + 1;
    end Droop_Quota;




    --  Extracts and sets up relevant entry metadata from the preference bundle map.
    procedure Read_Entries
    is
        Votes, Papers : Integer;
        This : Entry_Data;
    begin
        Entries := Entry_Vectors.Empty_Vector;
        for B in Pref_Data.Iterate loop
            Given_Bundles.Count_Both
               (Bundle_Containers.Bundle_Maps.Element (B).First_Element, Votes, Papers);
            This :=
               (ID            => Bundle_Containers.Bundle_Maps.Key (B),
                Vote_Change   => Votes,
                Total_Votes   => Votes,
                Paper_Change  => Papers,
                Total_Papers  => Papers,
                Status        => Running,
                Changed       => False,
                Order_Elected => 0);
            Entries.Append (This);
        end loop;
    end Read_Entries;




    --  This must be called before an election is run.
    procedure Setup
           (Candidate_Data           : in Candidates.Containers.Candidate_Map;
            Preference_File          : in String;
            Output_Dir, Main_Logfile : in String;
            Number_To_Elect          : in Natural;
            Is_Verbose               : in Boolean := False) is
    begin
        Verbose := Is_Verbose;

        if Verbose then
            Put_Line (Standard_Error, "Reading preference data...");
        end if;

        Bundle_Containers.Read_Bundles (Preference_File, Pref_Data);

        if Verbose then
            Put_Line (Standard_Error, "Done." & ASCII.LF);
            Put_Line (Standard_Error, "Setting up election...");
        end if;

        Cand_Data := Candidate_Data;
        Read_Entries;
        Exhausted := (others => 0);
        Fractional := (others => 0);
        Transfers := Transfer_Vectors.Empty_Vector;

        Out_Dir := SU.To_Unbounded_String (Output_Dir);
        Next_Log_Num := 1;
        Open (Main_Log, Append_File, Output_Dir & "/" & Main_Logfile);

        Seats := Number_To_Elect;
        Vacancies := Number_To_Elect;
        Total_Papers := 0;
        for E of Entries loop
            Total_Papers := Total_Papers + E.Total_Papers;
        end loop;
        Quota := Droop_Quota (Total_Papers, Seats);

        Work_To_Do := True;

        if Verbose then
            Put_Line (Standard_Error, "Done." & ASCII.LF);
        end if;
    end Setup;




    --  This is used because the 'Image attribute
    --  puts unwanted padding either side of numbers.
    function Int_Image
           (Number : in Integer)
        return String
    is
        use Ada.Strings;
        use Ada.Strings.Fixed;
        Result : String :=
            Trim (Integer'Image (Number), Both);
    begin
        return Result;
    end Int_Image;




    --  Outputs a new numbered csv logfile of the current status of the election.
    --  Automatically increments the logfile number afterwards.
    procedure Write_Log
    is
        Header : String :=
            "Seats,Vacancies,Total Papers,Quota," &
            Candidates.Candidate_Header &
            ",Papers,Change,Votes,Transfer,Status,Changed,Order Elected";

        Logname : String :=
            SU.To_String (Out_Dir) & "/" & Int_Image (Next_Log_Num) & ".csv";

        Change_Str, Order_Str : SU.Unbounded_String;

        Logfile : File_Type;
    begin
        Create (Logfile, Out_File, Logname);

        Put_Line (Logfile, Header);
        for E of Entries loop
            if E.Changed then
                Change_Str := SU.To_Unbounded_String ("True");
            else
                Change_Str := SU.To_Unbounded_String (0);
            end if;

            if E.Order_Elected > 0 then
                Order_Str := SU.To_Unbounded_String (Int_Image (E.Order_Elected));
            else
                Order_Str := SU.To_Unbounded_String (0);
            end if;

            Put_Line (Logfile,
                Int_Image (Seats) & "," &
                Int_Image (Vacancies) & "," &
                Int_Image (Total_Papers) & "," &
                Int_Image (Quota) & "," &
                Candidates.To_String (Cand_Data.Element (E.ID)) & "," &
                Int_Image (E.Total_Papers) & "," &
                Int_Image (E.Paper_Change) & "," &
                Int_Image (E.Total_Votes) & "," &
                Int_Image (E.Vote_Change) & "," &
                Candidate_Status'Image (E.Status) & "," &
                SU.To_String (Change_Str) & "," &
                SU.To_String (Order_Str));
        end loop;

        --  I don't really like how it's not obvious by looking at this
        --  whether the correct number of commas is being used.
        Put_Line (Logfile,
            ",,,,,,Fractional Loss,,," &
            Int_Image (Fractional.Total_Papers) & "," &
            Int_Image (Fractional.Paper_Change) & "," &
            ",,,,");
        Put_Line (Logfile,
            ",,,,,,Exhausted,,," &
            Int_Image (Exhausted.Total_Papers) & "," &
            Int_Image (Exhausted.Paper_Change) & "," &
            ",,,,");

        Close (Logfile);
        Next_Log_Num := Next_Log_Num + 1;
    end Write_Log;




    type Entry_Position is record
        Index       : Positive;
        Total_Votes : Natural;
    end record;


    package Position_Vectors is new Ada.Containers.Vectors
           (Index_Type   => Positive,
            Element_Type => Entry_Position);


    --  Ordering is stable with respect to the original candidate
    --  order in the event of multiple entries have equal votes.
    function "<"
           (Left, Right : in Entry_Position)
        return Boolean is
    begin
        if Left.Total_Votes = Right.Total_Votes then
            return Left.Index < Right.Index;
        else
            return Left.Total_Votes < Right.Total_Votes;
        end if;
    end "<";


    package Position_Sorting is new Position_Vectors.Generic_Sorting;


    --  The above types and this function are used to be able to sort
    --  still running entries by how many votes they have without
    --  messing up their original order, since the order should be
    --  consistent between numbered logfiles.
    function Get_Running_Entry_Positions
        return Position_Vectors.Vector
    is
        Result : Position_Vectors.Vector := Position_Vectors.Empty_Vector;
    begin
        for E in Entries.Iterate loop
            if Entry_Vectors.Element (E).Status = Running then
                Result.Append
                  ((Index       => Entry_Vectors.To_Index (E),
                    Total_Votes => Entry_Vectors.Element (E).Total_Votes));
            end if;
        end loop;
        return Result;
    end Get_Running_Entry_Positions;




    --  Only used by the Transfer_Votes function.
    function Get_Not_Running_IDs
        return Candidates.Containers.CandidateID_Sets.Set
    is
        Result : Candidates.Containers.CandidateID_Sets.Set :=
            Candidates.Containers.CandidateID_Sets.Empty_Set;
    begin
        for E of Entries loop
            if E.Status /= Running then
                Result.Insert (E.ID);
            end if;
        end loop;
        return Result;
    end Get_Not_Running_IDs;




    --  Helper function for Elect_Candidates and Check_No_Quota.
    --  Performs the actual marking of Entries as being Elected.
    procedure Elect
           (Index : Positive;
            ID    : Candidates.CandidateID)
    is
        Log_Msg : SU.Unbounded_String;
    begin
        Log_Msg := SU.To_Unbounded_String
           (Candidates.Name_And_Party (Cand_Data.Reference (ID)) &
            " elected at logfile #" & Int_Image (Next_Log_Num));
        Put_Line (Main_Log, SU.To_String (Log_Msg));
        if Verbose then
            Put_Line (Standard_Error, SU.To_String (Log_Msg));
        end if;

        Entries.Reference (Index).Status := Elected;
        Entries.Reference (Index).Changed := True;
        Entries.Reference (Index).Order_Elected := Seats - Vacancies + 1;

        Vacancies := Vacancies - 1;
    end Elect;




    --  Marks all the entries that have quota as elected, and adds a new
    --  Transfer for each of them to the transfer queue.
    function Elect_Candidates
        return Boolean
    is
        Running : Position_Vectors.Vector := Get_Running_Entry_Positions;

        Working_Position : Positive;
        Working_ID       : Candidates.CandidateID;
        Transfer_Value   : Rationals.Fraction;

        Number_Elected : Natural := 0;
    begin
        Position_Sorting.Sort (Running);

        for R in reverse Running.Iterate loop
            exit when Running.Reference (R).Total_Votes < Quota;
            Working_Position := Position_Vectors.Element (R).Index;
            Working_ID := Entries.Reference (Working_Position).ID;

            Elect (Working_Position, Working_ID);

            Transfer_Value := (Entries.Reference (Working_Position).Total_Votes - Quota) /
                Entries.Reference (Working_Position).Total_Votes;

            Number_Elected := Number_Elected + 1;
            Transfers.Append
                  ((From => Working_ID,
                    Position => Working_Position,
                    Value => Transfer_Value));
        end loop;

        return Number_Elected > 0;
    end Elect_Candidates;




    --  This step finishes up election processing if all vacancies are filled
    --  or if no further running Entries are available to fill them.
    function Check_If_Done
        return Boolean
    is
        Total_Still_Running : Natural := 0;
    begin
        for E of Entries loop
            if E.Status = Running then
                Total_Still_Running := Total_Still_Running + 1;
            end if;
        end loop;
        if Vacancies = 0 or Total_Still_Running = 0 then
            Close (Main_Log);
            Work_To_Do := False;
            return True;
        else
            return False;
        end if;
    end Check_If_Done;




    --  Helper function for Transfer_Votes.
    --  Performs the actual redistribution of preferences, generating new vote Bundles
    --  and adding them to the appropriate Entries. Also keeps a running total of how
    --  many papers were lost to fractional losses, and how many papers were exhausted.
    procedure Redistribute_Papers
           (Still_Running    : in     Position_Vectors.Vector;
            Already_Excluded : in     Candidates.Containers.CandidateID_Set;
            Transfer_Bundle  : in out Given_Bundles.Bundle;
            Transfer         : in     Pending_Transfer;
            Fractional_Loss  :    out Natural;
            Exhausted_Loss   :    out Natural)
    is
        Working_Position : Positive;
        Working_ID : Candidates.CandidateID;
        New_Bundle : Given_Bundles.Bundle;
        Votes_In, Papers_In : Natural;
    begin
        Fractional_Loss := 0;
        Exhausted_Loss := Given_Bundles.Count_Papers (Transfer_Bundle);

        for R in Still_Running.Iterate loop
            Working_Position := Still_Running.Constant_Reference (R).Index;
            Working_ID := Entries.Constant_Reference (Working_Position).ID;

            Given_Bundles.Transfer
                   (This     => Transfer_Bundle,
                    From     => Transfer.From,
                    To       => Working_ID,
                    Excluded => Already_Excluded,
                    Value    => Transfer.Value,
                    Result   => New_Bundle);
            Given_Bundles.Count_Both (New_Bundle, Votes_In, Papers_In);

            if Votes_In > 0 then
                Pref_Data.Reference (Working_ID).Append (New_Bundle);
                declare
                    Entry_Ref : Entry_Vectors.Reference_Type :=
                        Entries.Reference (Working_Position);
                begin
                    Entry_Ref.Vote_Change := Entry_Ref.Vote_Change + Votes_In;
                    Entry_Ref.Paper_Change := Entry_Ref.Paper_Change + Papers_In;
                    Entry_Ref.Total_Votes := Entry_Ref.Total_Votes + Votes_In;
                    Entry_Ref.Total_Papers := Entry_Ref.Total_Papers + Papers_In;
                end;
                Exhausted_Loss := Exhausted_Loss - Papers_In;
            elsif Papers_In > 0 then
                Fractional_Loss := Fractional_Loss + Papers_In;
                Exhausted_Loss := Exhausted_Loss - Papers_In;
            end if;
        end loop;
    end Redistribute_Papers;




    --  Takes the oldest Transfer from the transfer queue and uses the above
    --  helper function to perform it. Only performs a single transfer per call.
    function Transfer_Votes
        return Boolean
    is
        use type Ada.Containers.Count_Type;

        Running_Positions : Position_Vectors.Vector;
        Not_Considered : Candidates.Containers.CandidateID_Set;
        This_Transfer : Pending_Transfer;
        Fractional_Loss, Exhausted_Loss : Natural;
    begin
        if Integer (Transfers.Length) = 0 then
            return False;
        end if;

        Running_Positions := Get_Running_Entry_Positions;
        Not_Considered := Get_Not_Running_IDs;

        This_Transfer := Transfers.First_Element;

        while Pref_Data.Reference (This_Transfer.From).Length > 0 loop
            Redistribute_Papers
               (Still_Running    => Running_Positions,
                Already_Excluded => Not_Considered,
                Transfer_Bundle  => Pref_Data.Reference (This_Transfer.From).Reference
                                    (Pref_Data.Reference (This_Transfer.From).First_Index),
                Transfer         => This_Transfer,
                Fractional_Loss  => Fractional_Loss,
                Exhausted_Loss   => Exhausted_Loss);

            Pref_Data.Reference (This_Transfer.From).Delete (Pref_Data.Reference (This_Transfer.From).First_Index);

            Fractional.Paper_Change := Fractional.Paper_Change + Fractional_Loss;
            Exhausted.Paper_Change := Exhausted.Paper_Change + Exhausted_Loss;
        end loop;

        if Pref_Data.Reference (This_Transfer.From).Length = 0 then
            declare
                Entry_Ref : Entry_Vectors.Reference_Type :=
                    Entries.Reference (This_Transfer.Position);
            begin
                Entry_Ref.Paper_Change := - Entry_Ref.Total_Papers;
                Entry_Ref.Total_Papers := 0;
                if Entry_Ref.Status = Elected then
                    Entry_Ref.Vote_Change := Quota - Entry_Ref.Total_Votes;
                    Entry_Ref.Total_Votes := Quota;
                else
                    Entry_Ref.Vote_Change := - Entry_Ref.Total_Votes;
                    Entry_Ref.Total_Votes := 0;
                end if;
            end;
            Transfers.Delete_First;
        end if;

        Fractional.Total_Papers := Fractional.Total_Papers + Fractional.Paper_Change;
        Exhausted.Total_Papers := Exhausted.Total_Papers + Exhausted.Paper_Change;

        return True;
    end Transfer_Votes;




    --  If the number of running entries is only one more than the number of
    --  vacancies remaining to be filled, the entries with the highest vote
    --  totals can be elected without further vote transferral.
    function Check_No_Quota
        return Boolean
    is
        Running : Position_Vectors.Vector := Get_Running_Entry_Positions;

        Working_Position : Positive;
        Working_ID : Candidates.CandidateID;
    begin
        if Integer (Running.Length) > Vacancies + 1 then
            return False;
        end if;

        Position_Sorting.Sort (Running);

        for R in reverse Running.Iterate loop
            exit when Vacancies = 0;
            Working_Position := Position_Vectors.Element (R).Index;
            Working_ID := Entries.Reference (Working_Position).ID;
            Elect (Working_Position, Working_ID);
        end loop;

        return True;
    end Check_No_Quota;




    --  Implements bulk exclusions using applied breakpoints. Entries will be
    --  excluded in order of least vote count until the running total of excluded
    --  votes is as high as it can go without exceeding the difference between the
    --  running entry with the highest vote total and the quota. A minimum of one entry
    --  will always be excluded. A new Transfer for each excluded Entry is added
    --  to the transfer queue.
    --  (Note that this step does not yet implement proper tiebreaker handling.)
    function Exclude_Candidates
        return Boolean
    is
        Running : Position_Vectors.Vector := Get_Running_Entry_Positions;
        Log_Msg : SU.Unbounded_String;

        Working_ID : Candidates.CandidateID;
        Working_Position : Positive;

        Number_Excluded : Natural := 0;
        Votes_Excluded : Natural := 0;
        Votes_To_Be_Excluded : Natural;

        Applied_Breakpoint : Positive;
    begin
        Position_Sorting.Sort (Running);
        Applied_Breakpoint := Quota - Running.Reference (Running.Last_Index).Total_Votes;

        for R in Running.Iterate loop
            Votes_To_Be_Excluded := Running.Reference (R).Total_Votes;
            exit when Number_Excluded > 0 and Votes_Excluded + Votes_To_Be_Excluded > Applied_Breakpoint;

            Working_Position := Running.Reference (R).Index;
            Working_ID := Entries.Reference (Working_Position).ID;

            Entries.Reference (Working_Position).Status := Excluded;
            Entries.Reference (Working_Position).Changed := True;
            Transfers.Append ( (From => Working_ID, Position => Working_Position, Value => 1 / 1) );
            Votes_Excluded := Votes_Excluded + Votes_To_Be_Excluded;
            Number_Excluded := Number_Excluded + 1;
        end loop;

        if Number_Excluded > 1 then
            Log_Msg := SU.To_Unbounded_String
               ("Bulk exclusion of " & Int_Image (Number_Excluded) &
                " candidates at logfile #" & Int_Image (Next_Log_Num));
            Put_Line (Main_Log, SU.To_String (Log_Msg));
            if Verbose then
                Put_Line (Standard_Error, SU.To_String (Log_Msg));
            end if;
        end if;

        return Number_Excluded > 0;
    end Exclude_Candidates;




    --  The main loop of election processing. Each individual step returns
    --  a boolean value of whether or not it was applicable and did anything,
    --  which allows the use of the if statement.
    procedure Run is
    begin
        while Work_To_Do loop
            Write_Log;

            --  Clear marked changes in the entry list from
            --  previous iterations.
            for E of Entries loop
                E.Vote_Change := 0;
                E.Paper_Change := 0;
                E.Changed := False;
            end loop;
            Fractional.Paper_Change := 0;
            Exhausted.Paper_Change := 0;

            if  not Elect_Candidates and then
                not Check_If_Done and then
                not Transfer_Votes and then
                not Check_No_Quota and then
                not Exclude_Candidates
            then
                --  If all of the above procedures can't do
                --  anything then something is wrong.
                raise Program_Error;
            end if;
        end loop;
    end Run;




    --  A guard function to ensure nobody foolishly tries to run
    --  an election before setting it up.
    function Is_Properly_Setup
        return Boolean is
    begin
        return Work_To_Do;
    end Is_Properly_Setup;


end Election;