From 741f88ab405995003eb6e9f301d3b065c1e84a4a Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 28 Jan 2022 14:44:57 +0100 Subject: Added a motus solver --- motus/js/motus.ml | 197 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 197 insertions(+) create mode 100644 motus/js/motus.ml (limited to 'motus/js/motus.ml') diff --git a/motus/js/motus.ml b/motus/js/motus.ml new file mode 100644 index 0000000..f2995df --- /dev/null +++ b/motus/js/motus.ml @@ -0,0 +1,197 @@ +open Brr +open Brr_note +open Motus_lib +open Note +open StdLabels + +let ( let=? ) : 'a option -> ('a -> unit) -> unit = + fun f opt -> Option.iter opt f + + +let get_int_value element = + let value = El.prop El.Prop.value element in + match Jstr.to_int value with + | Some v -> v + | None -> 0 + + +let get_element_by_id id = + id |> Jv.Id.of_jv |> Jv.to_jstr |> Brr.Document.find_el_by_id Brr.G.document + + +let rule_to_element rule = + match rule with + | Criteria.Lenght l -> + Jstr.concat [ Jstr.v "Doit etre de longueur "; Jstr.of_int l ] + | Contain (c, None) -> Jstr.concat [ Jstr.v "Doit contenir "; Jstr.of_char c ] + | Contain (c, Some l) -> + Jstr.concat + [ Jstr.v "Doit contenir " + ; Jstr.of_char c + ; Jstr.v " à la position " + ; Jstr.of_int l + ] + | NotContain (c, None) -> + Jstr.concat [ Jstr.v "Ne doit pas contenir "; Jstr.of_char c ] + | NotContain (c, Some l) -> + Jstr.concat + [ Jstr.v "Ne doit pas contenir " + ; Jstr.of_char c + ; Jstr.v " à la position " + ; Jstr.of_int l + ] + + +let main + length_id + send_id + dictionnary_id + proposition_id + rules_id + table_id + next_btn_id + reload = + let=? length_element = get_element_by_id length_id in + let=? send_btn = get_element_by_id send_id in + let=? dictionnary_element = get_element_by_id dictionnary_id in + let=? proposition_element = get_element_by_id proposition_id in + let=? rules_element = get_element_by_id rules_id in + let=? table_element = get_element_by_id table_id in + let=? next_btn = get_element_by_id next_btn_id in + let=? reload = get_element_by_id reload in + + let change_event, sender = E.create () in + + let length_event = + Evr.on_el Ev.change (fun _ -> get_int_value length_element) length_element + in + let length_signal = S.hold (get_int_value length_element) length_event in + let initial_prop = FieldList.build proposition_element length_signal in + + let start_event = + Evr.on_el + Ev.click + (fun _ -> + (* Load the appropriate dictionnary *) + let dict_value = + El.prop El.Prop.value dictionnary_element |> Jstr.to_string + in + let length = get_int_value length_element in + let words = + match dict_value with + | "english" -> "./dicts/american-english_" ^ string_of_int length + | _ -> "./dicts/french_" ^ string_of_int length + in + + let proposition = S.value initial_prop in + + Elements.Transfert.get_content_from_url words + |> E.map (fun content -> + State.App.dispatch + (module Initialize) + Initialize.{ length; content; sender; proposition } ) ) + send_btn + |> E.join + in + + let change_event' = + E.map + (fun (position, letter, validity) -> + State.App.dispatch + (module UpdateProposition) + UpdateProposition.{ position; letter; validity } ) + change_event + in + + let btn_event = + Evr.on_el Ev.click (fun _ -> State.App.dispatch (module Next) ()) next_btn + in + + let update_event = + Evr.on_el Ev.click (fun _ -> State.App.dispatch (module Reload) ()) reload + in + + let ev = + State.App.run + ~eq:State.eq + (State.init ()) + (E.select + [ start_event (* Load a fresh dictionnary and start a new analysis *) + ; change_event' (* Update the proposition *) + ; btn_event (* Next line *) + ; update_event + ] ) + in + + (* Display all the rules on the right side *) + Elr.def_children + rules_element + (S.map + (fun State.{ rules; current_prop; _ } -> + let prev_rules = + List.map rules ~f:(fun e -> + let message = rule_to_element e in + El.li [ El.txt message ] ) + and new_rules = + List.map (State.get_current_rules current_prop) ~f:(fun e -> + let message = rule_to_element e in + El.li [ El.txt message ] ) + in + [ El.div prev_rules; El.hr (); El.div new_rules ] ) + ev ); + + (* Create the letter table *) + Elr.def_children + table_element + (S.map + (fun State.{ propositions; fields; _ } -> + let props = propositions in + let previous = + List.map props ~f:(fun proposition -> + List.map proposition ~f:(fun prop -> + let letter, validity = + Option.value ~default:(Jstr.empty, State.Missing) prop + in + let input = + El.input + ~at: + At. + [ type' (Jstr.v "text") + ; v (Jstr.v "maxLength") (Jstr.v "1") + ; value letter + ; class' (FieldList.get_class validity) + ] + () + in + El.td [ input ] ) + |> El.tr ) + in + El.tr fields :: previous ) + ev ); + + let last_element = + S.map + (fun ev -> + match (ev.State.current_prop, ev.State.analysis.number) with + | [], _ | _, 1 -> Some (Jstr.v "true") + | _, _ -> None ) + ev + in + + (* Hide the next btn when there is no proposition *) + Elr.def_at (Jstr.v "hidden") last_element next_btn; + Elr.def_at (Jstr.v "hidden") last_element reload; + + let log state = + ignore state; + () + in + + Logr.hold (S.log initial_prop log); + Logr.hold (S.log ev log) + + +let () = + let open Jv in + let main = obj [| ("run", repr main) |] in + set global "lib" main -- cgit v1.2.3