Commit 447e170e authored by Stephane Glondu's avatar Stephane Glondu

Support for blank votes in web interfaces

parent 2fa8ad5d
......@@ -144,6 +144,10 @@ let rec createQuestionNode sk params question_div num_questions i prev (q, answe
Dom.appendChild c t;
Dom.appendChild div c
in
let q_answers = match q.q_blank with
| Some true -> Array.append [|"Blank"|] q.q_answers
| _ -> q.q_answers
in
let () =
let choices = document##createElement (Js.string "div") in
Array.iteri (fun i a ->
......@@ -165,20 +169,33 @@ let rec createQuestionNode sk params question_div num_questions i prev (q, answe
);
Dom.appendChild div t;
Dom.appendChild choices div
) q.q_answers;
) q_answers;
Dom.appendChild div choices
in
let check_constraints () =
let total = Array.fold_left (+) 0 answers in
if total < q.q_min then (
let fmt = Scanf.format_from_string (getHtmlById "at_least") "%d" in
Printf.ksprintf alert fmt q.q_min;
false
) else if total > q.q_max then (
let fmt = Scanf.format_from_string (getHtmlById "at_most") "%d" in
Printf.ksprintf alert fmt q.q_max;
false
) else true
let check_min_max total =
if total < q.q_min then (
let fmt = Scanf.format_from_string (getHtmlById "at_least") "%d" in
Printf.ksprintf alert fmt q.q_min;
false
) else if total > q.q_max then (
let fmt = Scanf.format_from_string (getHtmlById "at_most") "%d" in
Printf.ksprintf alert fmt q.q_max;
false
) else true
in
match q.q_blank with
| Some true ->
let answers' = Array.sub answers 1 (Array.length answers - 1) in
let total = Array.fold_left (+) 0 answers' in
if answers.(0) > 0 then (
if total <> 0 then
(alert "No other choices are allowed when voting blank"; false)
else true
) else check_min_max total
| _ ->
let total = Array.fold_left (+) 0 answers in
check_min_max total
in
let () =
(* previous button *)
......@@ -231,7 +248,11 @@ let rec createQuestionNode sk params question_div num_questions i prev (q, answe
if a > 0 then (
incr checked;
let li = document##createElement (Js.string "li") in
let t = document##createTextNode (Js.string q.q_answers.(i)) in
let text = match q.q_blank with
| Some true -> if i = 0 then "Blank" else q.q_answers.(i-1)
| _ -> q.q_answers.(i)
in
let t = document##createTextNode (Js.string text) in
Dom.appendChild li t;
Dom.appendChild ul li;
)
......@@ -275,7 +296,7 @@ let addQuestions sk params qs =
let n = Array.length qs in
let qs =
Array.to_list qs |>
List.map (fun q -> q, Array.make (Array.length q.q_answers) 0)
List.map (fun q -> q, Array.make (Election.question_length q) 0)
in
match qs with
| [] -> failwith "no questions"
......
......@@ -46,7 +46,9 @@ let extractQuestion q =
try return (int_of_string x)
with _ -> failwith (error_msg ^ ": " ^ x ^ ".")
in
let q_blank = None in
p2##querySelector (Js.string ".question_blank") >>= fun q_blank ->
Dom_html.CoerceTo.input q_blank >>= fun q_blank ->
let q_blank = if Js.to_bool q_blank##checked then Some true else None in
numeric ".question_min" "Invalid minimum number of choices" >>= fun q_min ->
numeric ".question_max" "Invalid maximum number of choices" >>= fun q_max ->
if not (q_min <= q_max) then
......@@ -160,6 +162,15 @@ let rec createQuestion q =
let t = document##createTextNode (Js.string " answers.") in
Dom.appendChild x t;
Dom.appendChild container x;
(* is blank allowed? *)
let x = Dom_html.createDiv document in
let h_blank = Dom_html.createInput ~_type:(Js.string "checkbox") document in
h_blank##className <- Js.string "question_blank";
h_blank##checked <- Js.(match q.q_blank with Some true -> _true | _ -> _false);
Dom.appendChild x h_blank;
let t = document##createTextNode (Js.string "Blank vote is allowed") in
Dom.appendChild x t;
Dom.appendChild container x;
(* answers *)
let h_answers = Dom_html.createDiv document in
h_answers##className <- Js.string "question_answers";
......
......@@ -1180,6 +1180,10 @@ let election_home w state () =
return @@ div [
ul (List.mapi (fun i x ->
let answers = Array.to_list x.q_answers in
let answers = match x.q_blank with
| Some true -> "Blank" :: answers
| _ -> answers
in
let answers = List.mapi (fun j x ->
tr [td [pcdata x]; td [pcdata @@ string_of_int result.(i).(j)]]
) answers in
......
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