summaryrefslogtreecommitdiff
path: root/motus/js
diff options
context:
space:
mode:
Diffstat (limited to 'motus/js')
-rw-r--r--motus/js/dune19
-rw-r--r--motus/js/fieldList.ml173
-rw-r--r--motus/js/initialize.ml89
-rw-r--r--motus/js/motus.ml197
-rw-r--r--motus/js/next.ml36
-rw-r--r--motus/js/reload.ml31
-rw-r--r--motus/js/state.ml64
-rw-r--r--motus/js/updateProposition.ml24
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 }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 01:40:40 +0000