Commit 743bec66 authored by Stephane Glondu's avatar Stephane Glondu Committed by Stéphane Glondu

Add a command to apply the Majority Judgment method to a set of ballots

parent 07edeee9
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2020 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Serializable_j
let compute_matrix ~ngrades ~nchoices ballots =
let n = Array.length ballots in
let raw = Array.make_matrix nchoices ngrades 0 in
let rec add_ballot i spoiled =
if i < n then (
let ballot = ballots.(i) in
assert (nchoices = Array.length ballot);
let rec check j =
if j < nchoices then (
let grade = ballot.(j) in
if 0 < grade && grade <= ngrades then check (j + 1) else j
) else j
in
if check 0 = nchoices then (
let rec fill j =
if j < nchoices then (
let grade = ballot.(j) - 1 in
raw.(j).(grade) <- raw.(j).(grade) + 1;
fill (j + 1)
) else ()
in
fill 0;
add_ballot (i + 1) spoiled
) else add_ballot (i + 1) (ballot :: spoiled)
) else spoiled
in
let spoiled = add_ballot 0 [] in
raw, Array.of_list spoiled
let compute_increasing_vector grades =
let sum = Array.fold_left ( + ) 0 grades in
let res = Array.make sum (-1) in
let ngrades = Array.length grades in
let rec process i grade =
if grade < ngrades then (
let x = grades.(grade) in
assert (i + x <= sum);
let rec fill j n =
if n > 0 then (
res.(j) <- grade;
fill (j + 1) (n - 1)
) else j
in
let j = fill i x in
process j (grade + 1)
) else assert (i = sum)
in
process 0 0;
res
let compute_median_sequence increasing_vector =
let n = Array.length increasing_vector in
let tmp = Array.copy increasing_vector in
let res = Array.make n 0 in
for i = 0 to n - 1 do
let n' = n - i in
let imedian = (n' + 1) / 2 - 1 in
res.(i) <- tmp.(imedian);
Array.blit tmp (imedian + 1) tmp imedian (n' - 1 - imedian);
done;
res
let lex_compare a b =
let n = Array.length a in
assert (n = Array.length b);
let rec loop i =
if i < n then (
let x = a.(i) - b.(i) in
if x = 0 then loop (i + 1) else x
) else 0
in
loop 0
let compute_winners matrix =
let n = Array.length matrix in
let sorted =
matrix
|> Array.map compute_increasing_vector
|> Array.map compute_median_sequence
|> Array.mapi (fun i x -> i, x)
in
Array.sort (fun (_, a) (_, b) -> lex_compare a b) sorted;
let rec main i accu =
if i < n then
let a, aa = sorted.(i) in
let i', level =
let rec exaequos j accu =
if j < n then
let b, bb = sorted.(j) in
if lex_compare aa bb = 0 then
exaequos (j + 1) (b :: accu)
else
j, accu
else
j, accu
in
exaequos (i + 1) [a]
in
main i' (level :: accu)
else
List.rev accu
in
main 0 []
let compute ~ngrades ~nchoices ballots =
let mj_raw, mj_spoiled = compute_matrix ~ngrades ~nchoices ballots in
let mj_winners = compute_winners mj_raw in
{mj_raw; mj_spoiled; mj_winners}
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2020 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Serializable_t
val compute : ngrades:int -> nchoices:int -> mj_ballots -> mj_result
......@@ -257,3 +257,14 @@ type schulze_result = {
strongest : condorcet_matrix;
winners : int list list;
} <ocaml field_prefix="schulze_">
(** {2 Majority judgment} *)
type mj_ballots = int list <ocaml repr="array"> list <ocaml repr="array">
type mj_matrix = int list <ocaml repr="array"> list <ocaml repr="array">
type mj_result = {
raw : mj_matrix;
spoiled : mj_ballots;
winners : int list list;
} <ocaml field_prefix="mj_">
......@@ -789,7 +789,7 @@ end
module Methods : CMDLINER_MODULE = struct
let main nchoices =
let schulze nchoices =
wrap_main (fun () ->
let ballots = chars_of_stdin () |> condorcet_ballots_of_string in
let nchoices =
......@@ -806,10 +806,36 @@ module Methods : CMDLINER_MODULE = struct
|> print_endline
)
let mj nchoices ngrades =
wrap_main (fun () ->
let ballots = chars_of_stdin () |> mj_ballots_of_string in
let nchoices =
if nchoices = 0 then
if Array.length ballots > 0 then Array.length ballots.(0) else 0
else nchoices
in
if nchoices <= 0 then
failcmd "invalid --nchoices parameter (or could not infer it)"
else
let ngrades =
match ngrades with
| None -> failcmd "--ngrades is missing"
| Some i -> if i > 0 then i else failcmd "invalid --ngrades paramater"
in
ballots
|> Majority_judgment.compute ~nchoices ~ngrades
|> string_of_mj_result
|> print_endline
)
let nchoices_t =
let doc = "Number of choices. If 0, try to infer it." in
Arg.(value & opt int 0 & info ["nchoices"] ~docv:"N" ~doc)
let ngrades_t =
let doc = "Number of grades." in
Arg.(value & opt (some int) None & info ["ngrades"] ~docv:"G" ~doc)
let schulze_cmd =
let doc = "compute Schulze result" in
let man = [
......@@ -817,10 +843,20 @@ module Methods : CMDLINER_MODULE = struct
`P "This command reads on standard input JSON-formatted ballots and interprets them as Condorcet rankings on $(i,N) choices. It then computes the result according to the Schulze method and prints it on standard output.";
] @ common_man
in
Term.(ret (pure main $ nchoices_t)),
Term.(ret (pure schulze $ nchoices_t)),
Term.info "method-schulze" ~doc ~man
let cmds = [schulze_cmd]
let mj_cmd =
let doc = "compute Majority Judgment result" in
let man = [
`S "DESCRIPTION";
`P "This command reads on standard input JSON-formatted ballots and interprets them as grades (ranging from 1 (best) to $(i,G) (worst)) given to $(i,N) choices. It then computes the result according to the Majority Judgment method and prints it on standard output.";
] @ common_man
in
Term.(ret (pure mj $ nchoices_t $ ngrades_t)),
Term.info "method-majority-judgment" ~doc ~man
let cmds = [schulze_cmd; mj_cmd]
end
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment