diff options
Diffstat (limited to 'src/election.adb')
| -rw-r--r-- | src/election.adb | 520 |
1 files changed, 520 insertions, 0 deletions
diff --git a/src/election.adb b/src/election.adb new file mode 100644 index 0000000..059f9a9 --- /dev/null +++ b/src/election.adb @@ -0,0 +1,520 @@ + + +with Ada.Strings.Fixed; +with Ada.Strings.Unbounded; +with Ada.Text_IO; +use Ada.Text_IO; +with Rationals; + + +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; + + 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; + + 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; + elsif Papers_In > 0 then + Fractional.Paper_Change := Fractional.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; + + for From_Bundle of Pref_Data.Reference (Working_Transfer.From) loop + Papers_In := Given_Bundles.Count_Papers (From_Bundle); + if Papers_In > 0 then + Exhausted.Paper_Change := Exhausted.Paper_Change + Papers_In; + end if; + 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; + + |