Commit 181c8399 authored by Stephane Glondu's avatar Stephane Glondu Committed by Stéphane Glondu

Merge branch 'majority-judgment' into master

parents 07edeee9 d4eb59f3
Pipeline #181210 passed with stage
in 33 minutes and 6 seconds
(**************************************************************************)
(* 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
......
......@@ -111,6 +111,8 @@ let format_question_result uuid l (i, q) r =
txt (s_ "Available methods on this server:");
txt " ";
a ~service:method_schulze [txt "Condorcet-Schulze"] (uuid, i);
txt ", ";
a ~service:method_mj [txt (s_ "Majority Judgment")] (uuid, (i, None));
txt ".";
];
]
......@@ -838,6 +840,65 @@ let schulze q r =
in
base ~title ~content ()
let majority_judgment_select uuid question =
let%lwt l = get_preferred_gettext () in
let open (val l) in
let title = s_ "Majority Judgment method" in
let form =
get_form ~service:method_mj
(fun (uuidn, (questionn, ngradesn)) -> [
input ~input_type:`Hidden ~name:uuidn ~value:uuid (user raw_string_of_uuid);
input ~input_type:`Hidden ~name:questionn ~value:question int;
txt (s_ "Number of grades:");
txt " ";
input ~input_type:`Text ~name:ngradesn int;
input ~input_type:`Submit ~value:(s_ "Continue") string;
]
)
in
let content = [form] in
base ~title ~content ()
let majority_judgment q r =
let%lwt l = get_preferred_gettext () in
let open (val l) in
let title = s_ "Majority Judgment method" in
let explicit_winners =
List.map
(List.map
(fun i -> q.Question_nh_t.q_answers.(i))
) r.mj_winners
in
let pretty_winners =
List.map
(fun l ->
li [match l with
| [] -> failwith "anomaly in Pages_voter.majority_judgment"
| [x] -> txt x
| l -> div [
txt (s_ "Tie:");
ul (List.map (fun x -> li [txt x]) l);
]
]
) explicit_winners
in
let spoiled () = "data:application/json," ^ string_of_mj_ballots r.mj_spoiled in
let spoiled = uri_of_string spoiled in
let spoiled =
Eliom_content.Html.F.Raw.a ~a:[a_href spoiled]
[txt (s_ "Spoiled ballots")]
in
let content =
[
div [
txt (s_ "The Majority Judgment winners are:");
ol pretty_winners;
];
div [spoiled];
]
in
base ~title ~content ()
let contact_footer l metadata =
let open (val l : Web_i18n_sig.GETTEXT) in
match metadata.e_contact with
......
......@@ -35,6 +35,9 @@ val booth : unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val schulze : Question_nh_t.question -> schulze_result -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val majority_judgment_select : uuid -> int -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val majority_judgment : Question_nh_t.question -> mj_result -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val generate_password :
Web_serializable_t.metadata ->
string list ->
......
......@@ -273,6 +273,56 @@ let () =
)
)
let () =
Any.register ~service:method_mj
(fun (uuid, (question, ngrades)) () ->
let%lwt l = get_preferred_gettext () in
let open (val l) in
match%lwt find_election uuid with
| None -> election_not_found ()
| Some election ->
let questions = election.e_params.e_questions in
if 0 <= question && question < Array.length questions then (
match questions.(question) with
| Question.NonHomomorphic q ->
(match ngrades with
| None ->
Pages_voter.majority_judgment_select uuid question
>>= Html.send
| Some ngrades ->
if 0 < ngrades then (
let nchoices = Array.length q.Question_nh_t.q_answers in
match%lwt Web_persist.get_election_result uuid with
| Some result ->
let ballots =
(Shape.to_shape_array result.result).(question)
|> Shape.to_shape_array
|> Array.map Shape.to_array
in
let mj = Majority_judgment.compute ~nchoices ~ngrades ballots in
Pages_voter.majority_judgment q mj >>= Html.send
| None ->
Pages_common.generic_page ~title:(s_ "Error")
(s_ "The result of this election is not available.") ()
>>= Html.send ~code:404
) else (
Pages_common.generic_page ~title:(s_ "Error")
(s_ "The number of grades is invalid") ()
>>= Html.send ~code:400
)
)
| Question.Homomorphic _ ->
Pages_common.generic_page ~title:(s_ "Error")
(s_ "This question is homomorphic, the Majority Judgment method cannot be applied to its result.")
()
>>= Html.send ~code:403
) else (
Pages_common.generic_page ~title:(s_ "Error")
(s_ "Invalid index for question.") ()
>>= Html.send ~code:404
)
)
let content_type_of_file = function
| ESRaw -> "application/json; charset=utf-8"
| ESTrustees | ESETally | ESResult -> "application/json"
......
......@@ -139,3 +139,4 @@ let changepw_captcha_post = create_attached_post ~fallback:changepw_captcha ~pos
let changepw_post = create_attached_post ~fallback:signup ~post_params:(string "password" ** string "password2") ()
let method_schulze = create ~path:(Path ["methods"; "schulze"]) ~meth:(Get (uuid "uuid" ** int "question")) ()
let method_mj = create ~path:(Path ["methods"; "mj"]) ~meth:(Get (uuid "uuid" ** int "question" ** opt (int "ngrades"))) ()
......@@ -5,6 +5,7 @@ check:
./demo.sh
./demo-threshold.sh
./demo-nh.sh
./demo-mj.sh
clean:
rm -rf data
#!/bin/bash
set -e
export BELENIOS_USE_URANDOM=1
BELENIOS=${BELENIOS:-$(dirname $(dirname $PWD))}
belenios-tool () {
$BELENIOS/_run/tool-debug/bin/belenios-tool "$@"
}
header () {
echo
echo "=-=-= $1 =-=-="
echo
}
header "Setup election"
UUID=`belenios-tool generate-token`
echo "UUID of the election is $UUID"
DIR=$BELENIOS/tests/tool/data/$UUID
mkdir $DIR
cd $DIR
# Common options
uuid="--uuid $UUID"
group="--group $BELENIOS/files/groups/rfc3526-2048.json"
# Generate credentials
belenios-tool credgen $uuid $group --count 100
mv *.pubcreds public_creds.txt
mv *.privcreds private_creds.txt
# Generate trustee keys
belenios-tool trustee-keygen $group
belenios-tool trustee-keygen $group
belenios-tool trustee-keygen $group
cat *.pubkey > public_keys.jsons
# Generate trustee parameters
belenios-tool mktrustees
rm public_keys.jsons
# Generate election parameters
belenios-tool mkelection $uuid $group --template $BELENIOS/tests/tool/templates/questions-mj.json
header "Simulate votes"
cat > votes.txt <<EOF
[[1,1,1,1]]
[[1,1,1,1]]
[[1,1,1,1]]
[[1,1,1,1]]
[[1,1,1,1]]
[[1,1,1,1]]
[[1,1,2,1]]
[[1,1,2,1]]
[[1,1,2,1]]
[[1,1,2,1]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,1,2,2]]
[[1,2,2,3]]
[[1,2,2,3]]
[[1,2,2,3]]
[[1,2,2,3]]
[[1,2,2,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,3]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[2,2,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,3,4]]
[[3,3,4,5]]
[[3,3,4,5]]
[[3,3,4,5]]
[[3,3,4,5]]
[[3,3,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,4,4,5]]
[[4,5,4,5]]
[[5,5,4,5]]
[[5,5,4,5]]
[[5,5,4,5]]
[[5,5,4,5]]
[[5,5,5,5]]
[[5,5,5,5]]
[[5,5,5,5]]
[[5,5,5,5]]
[[5,5,5,5]]
[[5,5,5,5]]
EOF
paste private_creds.txt votes.txt | while read id cred vote; do
belenios-tool vote --privcred <(echo "$cred") --ballot <(echo "$vote")
echo "Voter $id voted" >&2
echo >&2
done > ballots.tmp
mv ballots.tmp ballots.jsons
header "Perform verification"
belenios-tool verify
header "Simulate and verify update"
tdir="$(mktemp -d)"
cp election.json public_creds.txt trustees.json "$tdir"
head -n3 ballots.jsons > "$tdir/ballots.jsons"
belenios-tool verify-diff --dir1="$tdir" --dir2=.
rm -rf "$tdir"
header "Shuffle ciphertexts"
belenios-tool shuffle > shuffles.jsons
echo >&2
belenios-tool shuffle >> shuffles.jsons
header "Perform decryption"
for u in *.privkey; do
belenios-tool decrypt --privkey $u
echo >&2
done > partial_decryptions.tmp
mv partial_decryptions.tmp partial_decryptions.jsons
header "Finalize tally"
belenios-tool validate
rm -f shuffles.jsons
header "Perform final verification"
belenios-tool verify
header "Apply Majority Judgment method"
cat > mj.reference <<EOF
{"raw":[[30,25,20,15,10],[25,30,20,14,11],[6,24,40,24,6],[10,15,20,25,30]],"spoiled":[],"winners":[[0],[1],[2],[3]]}
EOF
if command -v jq > /dev/null; then
if diff -u mj.reference <(jq --compact-output '.result[0]' < result.json | belenios-tool method-majority-judgment --ngrades 5); then
echo "Majority Judgment output is identical!"
else
echo "Differences in Majority Judgment output!"
exit 1
fi
else
echo "Could not find jq command, test skipped!"
fi
echo
echo "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-="
echo
echo "The simulated election was successful! Its result can be seen in"
echo " $DIR/result.json"
echo
echo "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-="
echo
{"description":"Description of the election.","name":"Name of the election","questions":[{"type":"NonHomomorphic","value":{"answers":["Answer 1","Answer 2","Answer 3","Answer 4"],"question":"Question?"}}]}
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