diff options
| -rw-r--r-- | src/bundles-containers.ads | 5 | ||||
| -rw-r--r-- | src/bundles.adb | 12 | ||||
| -rw-r--r-- | src/bundles.ads | 6 | ||||
| -rw-r--r-- | src/candidates-containers.ads | 2 | ||||
| -rw-r--r-- | src/candidates.adb | 29 | ||||
| -rw-r--r-- | src/candidates.ads | 12 | ||||
| -rw-r--r-- | src/election.adb | 520 | ||||
| -rw-r--r-- | src/election.ads | 75 | ||||
| -rw-r--r-- | src/stv.adb | 55 |
9 files changed, 680 insertions, 36 deletions
diff --git a/src/bundles-containers.ads b/src/bundles-containers.ads index d405e7e..9d52039 100644 --- a/src/bundles-containers.ads +++ b/src/bundles-containers.ads @@ -20,9 +20,12 @@ package Bundles.Containers is "=" => Bundle_Vectors."="); + subtype Bundle_Map is Bundle_Maps.Map; + + procedure Read_Bundles (Filename : in String; - Result : out Bundle_Maps.Map); + Result : out Bundle_Map); end Bundles.Containers; diff --git a/src/bundles.adb b/src/bundles.adb index 9701c40..50741ee 100644 --- a/src/bundles.adb +++ b/src/bundles.adb @@ -86,6 +86,18 @@ package body Bundles is + procedure Count_Both + (This : in Bundle; + Votes : out Natural; + Papers : out Natural) is + begin + Papers := Count_Papers (This); + Votes := Rationals.Floor (Papers * This.Worth); + end Count_Both; + + + + function "<" (Left, Right : in Bundle) return Boolean is diff --git a/src/bundles.ads b/src/bundles.ads index a58a232..5a0c274 100644 --- a/src/bundles.ads +++ b/src/bundles.ads @@ -40,6 +40,12 @@ package Bundles is return Natural; + procedure Count_Both + (This : in Bundle; + Votes : out Natural; + Papers : out Natural); + + function "<" (Left, Right : in Bundle) return Boolean; diff --git a/src/candidates-containers.ads b/src/candidates-containers.ads index 60fe4cb..142d1ca 100644 --- a/src/candidates-containers.ads +++ b/src/candidates-containers.ads @@ -60,7 +60,7 @@ package Candidates.Containers is package CandidateID_Sets is new Ada.Containers.Ordered_Sets - (Element_Type => CandidateID); + (Element_Type => Extended_CandidateID); subtype CandidateID_Set is CandidateID_Sets.Set; diff --git a/src/candidates.adb b/src/candidates.adb index 5d10ce1..40c038a 100644 --- a/src/candidates.adb +++ b/src/candidates.adb @@ -27,6 +27,35 @@ package body Candidates is end To_String; + + + function Candidate_Header + (Delimiter : in Character := ',') + return String is + begin + return "Group" & Delimiter & + "Group Rank" & Delimiter & + "First Name" & Delimiter & + "Last Name" & Delimiter & + "Party"; + end Candidate_Header; + + + + + function Name_And_Party + (Input_Candidate : in Candidate) + return String + is + use type SU.Unbounded_String; + begin + return SU.To_String + (Input_Candidate.First_Name & " " & + Input_Candidate.Last_Name & ", " & + Input_Candidate.Party); + end Name_And_Party; + + end Candidates; diff --git a/src/candidates.ads b/src/candidates.ads index fef8d4c..4e3caa6 100644 --- a/src/candidates.ads +++ b/src/candidates.ads @@ -26,7 +26,17 @@ package Candidates is function To_String (Input_Candidate : in Candidate; Delimiter : in Character := ',') - return String; + return String; + + + function Candidate_Header + (Delimiter : in Character := ',') + return String; + + + function Name_And_Party + (Input_Candidate : in Candidate) + return String; private 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; + + diff --git a/src/election.ads b/src/election.ads new file mode 100644 index 0000000..365ff35 --- /dev/null +++ b/src/election.ads @@ -0,0 +1,75 @@ + + +with Candidates.Containers; +with Bundles.Containers; +private with Ada.Containers.Vectors; + + +generic + with package Given_Bundles is new Bundles (<>); + with package Bundle_Containers is new Given_Bundles.Containers (<>); +package Election is + + + 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) + with Post => Is_Properly_Setup; + + + procedure Run + with Pre => Is_Properly_Setup; + + + function Is_Properly_Setup + return Boolean; + + +private + + + type Candidate_Status is (Elected, Running, Excluded); + + + type Entry_Data is record + ID : Candidates.CandidateID; + Vote_Change : Integer; + Total_Votes : Natural; + Paper_Change : Integer; + Total_Papers : Natural; + Status : Candidate_Status; + Changed : Boolean; + Order_Elected : Natural; + end record; + + + package Entry_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Entry_Data); + + + type Pending_Transfer is record + From : Candidates.CandidateID; + Position : Positive; + end record; + + + package Transfer_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Pending_Transfer); + + + -- this is used to keep track of exhausted and + -- fractional loss votes/papers + type Extra_Data is record + Paper_Change : Integer; + Total_Papers : Natural; + end record; + + +end Election; + + diff --git a/src/stv.adb b/src/stv.adb index e6df17e..4f8ef5a 100644 --- a/src/stv.adb +++ b/src/stv.adb @@ -11,6 +11,7 @@ with CSV; with Candidates.Containers; with Preferences; with Bundles.Containers; +with Election; procedure STV is @@ -183,6 +184,14 @@ begin end if; + -- check number to elect option is valid + if Number_To_Elect < 1 then + Put_Line ("Number of candidates to be elected too low." & ASCII.LF & Further_Help); + ACom.Set_Exit_Status (ACom.Failure); + return; + end if; + + -- check state option is valid begin State := Candidates.State_Name'Value (State_String.all); @@ -207,7 +216,7 @@ begin end if; - -- set up the election processing + -- read in candidate data, which is necessary for further setup if Verbose then Put_Line (Standard_Error, "Reading candidate data..."); end if; @@ -215,6 +224,7 @@ begin Candidates.Containers.Generate_Ballots (Candidate_Data, Above_Ballot, Below_Ballot); + -- set up and run the election singleton declare package Given_Prefs is new Preferences (Pref_Size => Integer (Below_Ballot.Length), @@ -226,39 +236,18 @@ begin package Vote_Bundle_Containers is new Vote_Bundles.Containers; - Initial_Bundles : Vote_Bundle_Containers.Bundle_Maps.Map; + package This_Election is new Election + (Given_Bundles => Vote_Bundles, + Bundle_Containers => Vote_Bundle_Containers); begin - if Verbose then - Put_Line (Standard_Error, "Reading preference data..."); - end if; - Vote_Bundle_Containers.Read_Bundles (Preference_File.all, Initial_Bundles); - if Verbose then - Put_Line (Standard_Error, "Done." & ASCII.LF); - Put_Line (Standard_Error, "Setting up election..."); - end if; - -- set up election here - if Verbose then - Put_Line (Standard_Error, "Done." & ASCII.LF); - end if; - - - -- test output to check that votes were parsed correctly - for Cursor in Initial_Bundles.Iterate loop - Put_Line - (Candidates.CandidateID'Image (Vote_Bundle_Containers.Bundle_Maps.Key (Cursor)) & - " " & - Integer'Image (Vote_Bundles.Count_Votes (Vote_Bundle_Containers.Bundle_Maps.Element (Cursor).Element (1)))); - end loop; - - - -- run the show - if Verbose then - Put_Line (Standard_Error, "Running..." & ASCII.LF); - end if; - -- run election here - if Verbose then - New_Line (Standard_Error); - end if; + This_Election.Setup + (Candidate_Data => Candidate_Data, + Preference_File => Preference_File.all, + Output_Dir => Output_Dir.all, + Main_Logfile => "log.txt", + Number_To_Elect => Number_To_Elect, + Is_Verbose => Verbose); + This_Election.Run; end; |