Commit 842fb751 authored by Stephane Glondu's avatar Stephane Glondu Committed by Stéphane Glondu

Propose the Majority Judgment method on election result page

parent 9c73ae76
Pipeline #181166 passed with stages
in 64 minutes and 50 seconds
......@@ -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,62 @@ 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 = "<a href=\"" ^ spoiled ^ "\">" ^ s_ "Spoiled ballots" ^ "</a>" in
let spoiled = Unsafe.data spoiled 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"))) ()
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