with Ada.Strings.Fixed; with Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with Rationals; -- This source is licensed under Creative Commons CC0 v1.0. -- -- To read the full text, see license.txt in the main directory of this repository -- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt -- -- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/ package body Election is package SU renames Ada.Strings.Unbounded; Cand_Data : Candidates.Containers.Candidate_Map; Pref_Data : Bundle_Containers.Bundle_Map; Entries : Entry_Vectors.Vector; Exhausted : Extra_Data; Fractional : Extra_Data; Transfers : Transfer_Vectors.Vector; Out_Dir : SU.Unbounded_String; Next_Log_Num : Positive; Main_Log : File_Type; Seats : Natural; Vacancies : Natural; Total_Papers : Natural; Quota : Natural; 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; -- needs to be refactored due to length 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; -- setup/extract relevant metadata from the vote bundle map for B in Pref_Data.Iterate loop declare Votes, Papers : Integer; This : Entry_Data; begin 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; end loop; Exhausted := (others => 0); Fractional := (others => 0); Transfers := Transfer_Vectors.Empty_Vector; Cand_Data := Candidate_Data; Out_Dir := SU.To_Unbounded_String (Output_Dir); Next_Log_Num := 1; 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); Open (Main_Log, Append_File, Output_Dir & "/" & Main_Logfile); Work_To_Do := True; if Verbose then Put_Line (Standard_Error, "Done." & ASCII.LF); end if; end Setup; procedure Write_Log is use Ada.Strings; use Ada.Strings.Fixed; 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) & "/" & Trim (Integer'Image (Next_Log_Num), Both) & ".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 (Trim (Integer'Image (E.Order_Elected), Both)); else Order_Str := SU.To_Unbounded_String (0); end if; Put_Line (Logfile, Trim (Integer'Image (Seats), Both) & "," & Trim (Integer'Image (Vacancies), Both) & "," & Trim (Integer'Image (Total_Papers), Both) & "," & Trim (Integer'Image (Quota), Both) & "," & Candidates.To_String (Cand_Data.Element (E.ID)) & "," & Trim (Integer'Image (E.Total_Papers), Both) & "," & Trim (Integer'Image (E.Paper_Change), Both) & "," & Trim (Integer'Image (E.Total_Votes), Both) & "," & Trim (Integer'Image (E.Vote_Change), Both) & "," & Candidate_Status'Image (E.Status) & "," & SU.To_String (Change_Str) & "," & SU.To_String (Order_Str)); end loop; Put_Line (Logfile, ",,,,,,Fractional Loss,,," & Trim (Integer'Image (Fractional.Total_Papers), Both) & "," & Trim (Integer'Image (Fractional.Paper_Change), Both) & "," & ",,,,"); Put_Line (Logfile, ",,,,,,Exhausted,,," & Trim (Integer'Image (Exhausted.Total_Papers), Both) & "," & Trim (Integer'Image (Exhausted.Paper_Change), Both) & "," & ",,,,"); Close (Logfile); 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); 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; function Extract_Running_Entries 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 Extract_Running_Entries; procedure Elect (Index : Positive; ID : Candidates.CandidateID) is use Ada.Strings; use Ada.Strings.Fixed; Log_Msg : SU.Unbounded_String; begin Log_Msg := SU.To_Unbounded_String (Candidates.Name_And_Party (Cand_Data.Reference (ID)) & " elected at logfile #" & Trim (Integer'Image (Next_Log_Num), Both)); 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; function Elect_Candidates return Boolean is Running : Position_Vectors.Vector := Extract_Running_Entries; Working_Position : Positive; Working_ID : Candidates.CandidateID; 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); Number_Elected := Number_Elected + 1; Transfers.Append ( (From => Working_ID, Position => Working_Position) ); end loop; return Number_Elected > 0; end Elect_Candidates; 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; -- need to refactor this due to length function Transfer_Votes return Boolean is use type Ada.Containers.Count_Type; use type Rationals.Fraction; Still_Running : Position_Vectors.Vector; Not_Considered : Candidates.Containers.CandidateID_Set; Working_Transfer : Pending_Transfer; Working_Position : Positive; Working_ID : Candidates.CandidateID; Working_Value : Rationals.Fraction; New_Bundle : Given_Bundles.Bundle; Votes_In, Papers_In : Natural; begin if Transfers.Length = 0 then return False; end if; Still_Running := Extract_Running_Entries; Not_Considered := Candidates.Containers.CandidateID_Sets.Empty_Set; for E of Entries loop if E.Status /= Running then Not_Considered.Insert (E.ID); end if; end loop; Working_Transfer := Transfers.First_Element; Transfers.Delete_First; Exhausted.Paper_Change := Entries.Reference (Working_Transfer.Position).Total_Papers; if Entries.Reference (Working_Transfer.Position).Status = Excluded then Entries.Reference (Working_Transfer.Position).Vote_Change := - Entries.Reference (Working_Transfer.Position).Total_Votes; Working_Value := 1 / 1; Entries.Reference (Working_Transfer.Position).Total_Votes := 0; else Entries.Reference (Working_Transfer.Position).Vote_Change := Quota - Entries.Reference (Working_Transfer.Position).Total_Votes; Working_Value := (Entries.Reference (Working_Transfer.Position).Total_Votes - Quota) / Entries.Reference (Working_Transfer.Position).Total_Votes; Entries.Reference (Working_Transfer.Position).Total_Votes := Quota; end if; Entries.Reference (Working_Transfer.Position).Paper_Change := - Entries.Reference (Working_Transfer.Position).Total_Papers; Entries.Reference (Working_Transfer.Position).Total_Papers := 0; for R in Still_Running.Iterate loop Working_Position := Still_Running.Reference (R).Index; Working_ID := Entries.Reference (Working_Position).ID; for B in Pref_Data.Reference (Working_Transfer.From).Iterate loop Given_Bundles.Transfer (This => Pref_Data.Reference (Working_Transfer.From).Reference (B), From => Working_Transfer.From, To => Working_ID, Excluded => Not_Considered, Value => Working_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); Entries.Reference (Working_Position).Vote_Change := Entries.Reference (Working_Position).Vote_Change + Votes_In; Entries.Reference (Working_Position).Paper_Change := Entries.Reference (Working_Position).Paper_Change + Papers_In; Exhausted.Paper_Change := Exhausted.Paper_Change - Papers_In; elsif Papers_In > 0 then Fractional.Paper_Change := Fractional.Paper_Change + Papers_In; Exhausted.Paper_Change := Exhausted.Paper_Change - Papers_In; end if; end loop; Entries.Reference (Working_Position).Total_Votes := Entries.Reference (Working_Position).Total_Votes + Entries.Reference (Working_Position).Vote_Change; Entries.Reference (Working_Position).Total_Papers := Entries.Reference (Working_Position).Total_Papers + Entries.Reference (Working_Position).Paper_Change; end loop; Pref_Data.Replace (Working_Transfer.From, Bundle_Containers.Bundle_Vectors.Empty_Vector); Fractional.Total_Papers := Fractional.Total_Papers + Fractional.Paper_Change; Exhausted.Total_Papers := Exhausted.Total_Papers + Exhausted.Paper_Change; return True; end Transfer_Votes; function Check_No_Quota return Boolean is Running : Position_Vectors.Vector := Extract_Running_Entries; 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; function Exclude_Candidates return Boolean is use Ada.Strings; use Ada.Strings.Fixed; Running : Position_Vectors.Vector := Extract_Running_Entries; 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) ); 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 " & Trim (Integer'Image (Number_Excluded), Both) & " candidates at logfile #" & Trim (Integer'Image (Next_Log_Num), Both)); 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; procedure Run is begin while Work_To_Do loop Write_Log; Next_Log_Num := Next_Log_Num + 1; 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; function Is_Properly_Setup return Boolean is begin return Work_To_Do; end Is_Properly_Setup; end Election;