Added a motus solver

8 files changed, 633 insertions, 0 deletions

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 }