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/dune | 19 ++++ motus/js/fieldList.ml | 173 +++++++++++++++++++++++++++++++++++++ motus/js/initialize.ml | 89 +++++++++++++++++++ motus/js/motus.ml | 197 ++++++++++++++++++++++++++++++++++++++++++ motus/js/next.ml | 36 ++++++++ motus/js/reload.ml | 31 +++++++ motus/js/state.ml | 64 ++++++++++++++ motus/js/updateProposition.ml | 24 +++++ 8 files changed, 633 insertions(+) create mode 100644 motus/js/dune create mode 100644 motus/js/fieldList.ml create mode 100644 motus/js/initialize.ml create mode 100644 motus/js/motus.ml create mode 100644 motus/js/next.ml create mode 100644 motus/js/reload.ml create mode 100644 motus/js/state.ml create mode 100644 motus/js/updateProposition.ml (limited to 'motus/js') diff --git a/motus/js/dune b/motus/js/dune new file mode 100644 index 0000000..9dd3113 --- /dev/null +++ b/motus/js/dune @@ -0,0 +1,19 @@ +(executable + (name motus) + (libraries + brr + brr.note + application + elements + motus_lib + ) + (modes js) + (preprocess (pps js_of_ocaml-ppx)) + (link_flags (:standard -no-check-prims)) + ) + +(rule + (targets motus.js) + (deps motus.bc.js) + (action (copy %{deps} %{targets}))) + diff --git a/motus/js/fieldList.ml b/motus/js/fieldList.ml new file mode 100644 index 0000000..85755aa --- /dev/null +++ b/motus/js/fieldList.ml @@ -0,0 +1,173 @@ +open Brr +open Note +open Brr_note +open StdLabels + +type elements = Brr.El.t list + +(** Depending of the class, extract the letter validity. + + If no class is specified, consider the letter is at the right position. + + *) +let get_validity_from_element : El.t -> State.letter_validity = + fun el -> + if El.class' (Jstr.v "missing") el + then State.Missing + else if El.class' (Jstr.v "misplaced") el + then State.Misplaced + else State.Wellplaced + + +let get_rules : elements -> State.proposition = + fun t -> + List.map + ~f:(fun input -> + let value = El.prop El.Prop.value input in + if Jstr.equal Jstr.empty value + then None + else + let validity = get_validity_from_element input in + Some (value, validity) ) + t + + +let get_class : State.letter_validity -> Jstr.t = function + | Wellplaced -> Jstr.v "wellplaced" + | Misplaced -> Jstr.v "misplaced" + | _ -> Jstr.v "missing" + + +(** Create the field list modifiied by the user *) +let make : int -> (int * Jstr.t * State.letter_validity) E.send -> elements = + fun len change_sender -> + List.init ~len ~f:(fun i -> + let input = + El.input + ~at: + At. + [ type' (Jstr.v "text") + ; v (Jstr.v "maxLength") (Jstr.v "1") + ; value Jstr.empty + ; class' (Jstr.v "missing") + ; v (Jstr.v "readonly") (Jstr.v "true") + ] + () + in + + Ev.listen + Ev.change + (fun _ -> + let validity = get_validity_from_element input in + change_sender (i, El.prop El.Prop.value input, validity) ) + (El.as_target input); + Ev.listen + Ev.click + (fun _ -> + let validity = + match get_validity_from_element input with + | State.Missing -> State.Misplaced + | State.Misplaced -> State.Wellplaced + | State.Wellplaced -> State.Missing + in + change_sender (i, El.prop El.Prop.value input, validity) ) + (El.as_target input); + + El.td [ input ] ) + + +(** Set the element class depending of the proposition validity for each letter + *) +let set_with_props : + State.proposition -> elements -> Motus_lib.Criteria.t list -> unit = + fun current_prop fields rules -> + let i = ref 0 in + List.iter2 current_prop fields ~f:(fun prop field -> + (* Check if we have a rule for this letter *) + let wellplaced = + List.exists rules ~f:(function + | Motus_lib.Criteria.Contain (_, Some i') when !i = i' -> true + | _ -> false ) + in + incr i; + + match (wellplaced, El.children field, prop) with + | true, hd :: _, Some (letter, _) -> + El.set_prop El.Prop.value letter hd; + El.set_class (Jstr.v "wellplaced") true hd; + El.set_class (Jstr.v "misplaced") false hd; + El.set_class (Jstr.v "missing") false hd; + El.set_at (Jstr.v "readonly") (Some (Jstr.v "true")) hd + | _, hd :: _, None -> + El.set_class (Jstr.v "wellplaced") false hd; + El.set_class (Jstr.v "misplaced") false hd; + El.set_class (Jstr.v "missing") false hd + | false, hd :: _, Some (letter, validity) -> + El.set_prop El.Prop.value letter hd; + El.set_class (Jstr.v "wellplaced") false hd; + El.set_class (Jstr.v "misplaced") false hd; + El.set_class (Jstr.v "missing") false hd; + El.set_class (get_class validity) true hd + | _, [], _ -> () ) + + +let build : El.t -> int S.t -> State.proposition S.t = + fun container length -> + (* Build the element list *) + S.bind length (fun len -> + let elements = + List.init ~len ~f:(fun _ -> + let input = + El.input + ~at: + At. + [ type' (Jstr.v "text") + ; v (Jstr.v "maxLength") (Jstr.v "1") + ; value Jstr.empty + ] + () + in + input ) + in + let events = + List.mapi + ~f:(fun i input -> + Evr.on_el + Ev.input + (fun _ -> + let value = El.prop El.Prop.value input in + if Jstr.equal Jstr.empty value + then (i, None) + else + let validity = State.Wellplaced in + (i, Some (Jstr.uppercased value, validity)) ) + input ) + elements + (* As the state is in a list, we have no way to be sure that the list + length is the same as the number of elements… except to rely on the + compiler contract. + + But this would cause nasty bug if we had a difference here. + *) + and init_prop = List.init ~len ~f:(fun _ -> None) in + + (* Replace the children in the element *) + El.set_children + container + [ El.table + [ (* The table has only one row *) + El.tr + (List.map elements ~f:(fun el -> + El.td [ (* Each cell is the input element *) el ] ) ) + ] + ]; + + let change = + E.select events + |> E.map (fun (position, value) acc -> + List.mapi acc ~f:(fun i prop -> + if i <> position then prop else value ) ) + in + let initial_proposition = S.accum init_prop change in + + initial_proposition ) diff --git a/motus/js/initialize.ml b/motus/js/initialize.ml new file mode 100644 index 0000000..7dd7544 --- /dev/null +++ b/motus/js/initialize.ml @@ -0,0 +1,89 @@ +open StdLabels +open Note +open Motus_lib +open Brr + +type t = + { length : int + ; content : (int * Jstr.t, Jv.Error.t) result + ; sender : (int * Jstr.t * State.letter_validity) E.send + ; proposition : State.proposition + } + +(** Pick the next word from the dictionnary, and return it as a proposition. + + If the word is empty (no word) return [None], else return a proposition + which can be edited by the user. + + The rule list is used to identify the letter already fixed by the previous + results. + + *) +let get_proposition : + Persistence.t -> Criteria.t list -> State.proposition option = + fun analysis rules -> + let word = + Persistence.extract_freq analysis + |> Persistence.pick_next_word analysis + |> fst + in + match String.equal String.empty word with + | true -> None + | false -> + let i = ref 0 in + let proposition = + word + |> String.to_seq + |> Seq.map (fun c -> + let wellplaced = + List.exists rules ~f:(function + | Motus_lib.Criteria.Contain (_, Some i') when !i = i' -> + true + | _ -> false ) + in + incr i; + let validity = + match wellplaced with + | true -> State.Wellplaced + | _ -> State.Missing + in + + Some (Jstr.of_char c, validity) ) + |> List.of_seq + in + Some proposition + + +let process { sender; length; content; proposition } state = + match content with + | Ok (200, value) -> + let rules = + Criteria.Lenght length :: State.get_current_rules proposition + in + let words = Jstr.cuts ~sep:(Jstr.v "\n") value in + let analysis = + List.fold_left + ~f:(fun a w -> + let upper = Jstr.uppercased w in + Persistence.add_word rules a (Jstr.to_string upper) ) + ~init:(Persistence.empty_data ()) + words + in + let current_prop = get_proposition analysis rules + and fields = FieldList.make length sender in + ( match current_prop with + | None -> state + | Some prop -> + FieldList.set_with_props prop fields rules; + + State. + { analysis + ; rules + ; length + ; current_prop = prop + ; propositions = [] + ; fields + } ) + | _ -> + Console.(log [ Jstr.v "No words found" ]); + state 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 diff --git a/motus/js/next.ml b/motus/js/next.ml new file mode 100644 index 0000000..658590d --- /dev/null +++ b/motus/js/next.ml @@ -0,0 +1,36 @@ +(** Load the next proposition from the word list *) + +open StdLabels + +type t = unit + +let process : t -> State.state -> State.state = + fun () state -> + (* Add the current proposition into the validated list *) + let rules = State.get_current_rules state.current_prop in + + let rules = + Motus_lib.Criteria.merge_lists ~init:state.rules rules + |> List.sort_uniq ~cmp:Stdlib.compare + in + + (* Update the word list with the new rules *) + let analysis = + List.fold_left + ~f:(Motus_lib.Persistence.add_word rules) + ~init:(Motus_lib.Persistence.empty_data ()) + state.analysis.Motus_lib.Persistence.element + in + + let propositions = state.current_prop :: state.propositions + and current_prop = [] in + + let new_state = { state with propositions; current_prop; rules; analysis } in + + (* Get the new proposition if any *) + let current_prop = Initialize.get_proposition analysis rules in + match current_prop with + | None -> new_state + | Some prop -> + FieldList.set_with_props prop state.fields new_state.rules; + State.{ new_state with rules; current_prop = prop } diff --git a/motus/js/reload.ml b/motus/js/reload.ml new file mode 100644 index 0000000..3a461ee --- /dev/null +++ b/motus/js/reload.ml @@ -0,0 +1,31 @@ +open StdLabels + +type t = unit + +let process : t -> State.state -> State.state = + fun () state -> + (* Get the word corresponding to the proposition *) + let word = + state.State.current_prop + |> List.to_seq + |> Seq.map (fun opt -> + match opt with + | None -> ' ' + | Some (letter, _) -> String.get (Jstr.to_string letter) 0 ) + |> String.of_seq + in + + let element = + List.filter + ~f:(fun w -> not (String.equal w word)) + state.State.analysis.element + in + let analysis = { state.analysis with element } in + let new_state = { state with analysis } in + (* Get the new proposition if any *) + let current_prop = Initialize.get_proposition analysis state.rules in + match current_prop with + | None -> new_state + | Some prop -> + FieldList.set_with_props prop state.fields new_state.rules; + State.{ new_state with current_prop = prop } diff --git a/motus/js/state.ml b/motus/js/state.ml new file mode 100644 index 0000000..57a3794 --- /dev/null +++ b/motus/js/state.ml @@ -0,0 +1,64 @@ +open StdLabels +open Motus_lib + +type letter_validity = + | Wellplaced + | Misplaced + | Missing + +type proposition = (Jstr.t * letter_validity) option list + +type state = + { analysis : Persistence.t + ; rules : Criteria.t list + ; length : int + ; propositions : proposition list + ; current_prop : proposition + ; fields : Brr.El.t list + } + +let init () = + { analysis = Persistence.empty_data () + ; rules = [] + ; length = 0 + ; propositions = [] + ; current_prop = [] + ; fields = [] + } + + +module App = Application.Make (struct + type t = state +end) + +(** Get the current rules to apply with from the field list *) +let get_current_rules : proposition -> Criteria.t list = + fun prop -> + let rules = ref [] in + List.iteri prop ~f:(fun i prop -> + Option.iter + (fun (letter, validity) -> + if Jstr.equal Jstr.empty letter + then () + else + let char = String.get (Jstr.to_string letter) 0 in + + match validity with + | Missing -> + rules := Criteria.add (Criteria.NotContain (char, None)) !rules + | Misplaced -> + rules := + Criteria.add (Criteria.NotContain (char, Some i)) !rules; + rules := Criteria.add (Criteria.Contain (char, None)) !rules + | Wellplaced -> + rules := Criteria.add (Criteria.Contain (char, Some i)) !rules + ) + prop ); + List.rev !rules + + +(** Compare two states *) +let eq : state -> state -> bool = + fun s1 s2 -> + (s1.length, s1.rules, s1.current_prop, s1.propositions, s1.analysis) + = (s2.length, s2.rules, s2.current_prop, s2.propositions, s2.analysis) diff --git a/motus/js/updateProposition.ml b/motus/js/updateProposition.ml new file mode 100644 index 0000000..ab10db3 --- /dev/null +++ b/motus/js/updateProposition.ml @@ -0,0 +1,24 @@ +(** Update the current propositions when the user change a value in one of the + field. + *) + +open StdLabels + +type t = + { position : int + ; letter : Jstr.t + ; validity : State.letter_validity + } + +let process { position; letter; validity } state = + let current_prop = + List.mapi state.State.current_prop ~f:(fun pos' content -> + if position <> pos' + then content + else if Jstr.is_empty letter + then None + else Some (Jstr.uppercased letter, validity) ) + in + FieldList.set_with_props current_prop state.fields state.rules; + + { state with current_prop } -- cgit v1.2.3