Added a motus solver

2 files changed, 155 insertions, 0 deletions

diff --git a/motus/bin/dune b/motus/bin/dune
new file mode 100644
index 0000000..282fa7f
--- /dev/null
+++ b/motus/bin/dune
@@ -0,0 +1,7 @@
+(executables
+ (names 
+    motus
+ )
+ (libraries motus_lib)
+ )
+
diff --git a/motus/bin/motus.ml b/motus/bin/motus.ml
new file mode 100644
index 0000000..fe00a3c
--- /dev/null
+++ b/motus/bin/motus.ml
@@ -0,0 +1,148 @@
+open Motus_lib
+
+(** Represent a decision rule *)
+let format_filter : Format.formatter -> Criteria.t -> unit =
+ fun formatter f ->
+  match f with
+  | Lenght l -> Format.fprintf formatter "Doit etre de longueur %d" l
+  | Contain (c, None) -> Format.fprintf formatter "Doit contenir un %c" c
+  | Contain (c, Some i) ->
+      Format.fprintf formatter "Doit contenir un %c a la position %d" c i
+  | NotContain (c, None) ->
+      Format.fprintf formatter "Ne doit pas contenir un %c" c
+  | NotContain (c, Some i) ->
+      Format.fprintf formatter "Ne doit pas contenir un %c a la position %d" c i
+
+
+(** Display the informations about the structure *)
+let show_structure :
+    Format.formatter -> Persistence.t -> Criteria.t list -> unit =
+ fun format data filters ->
+  Format.fprintf
+    format
+    "Filtres en cours : @[<v>%a@]@\n"
+    (Format.pp_print_list format_filter)
+    filters;
+
+  Format.fprintf format "Got %d elements @\n" data.number;
+
+  Format.fprintf
+    format
+    "Frequencies : @[<v>%a@]@\n"
+    (Format.pp_print_list (fun f (k, v) -> Format.fprintf f "%c -> %d" k v))
+    (Persistence.extract_freq data);
+
+  if data.number < 20
+  then
+    Format.fprintf
+      format
+      "Remaining words @[<v>@;%a@]@\n"
+      (Format.pp_print_list ~pp_sep:Format.pp_force_newline (fun f w ->
+           Format.fprintf f "%s" w ) )
+      data.element;
+  Format.close_box ()
+
+
+(** Get the initial list *)
+let rec get_list :
+    in_channel -> Persistence.t -> Criteria.t list -> Persistence.t =
+ fun channel data filters ->
+  let word =
+    try Some (String.lowercase_ascii (Stdlib.input_line channel)) with
+    | End_of_file -> None
+  in
+  match word with
+  | None -> data
+  | Some word ->
+      let data = Persistence.add_word filters data word in
+      get_list channel data filters
+
+
+(** Compare the proposed word and the result from the user in order to identify
+    the future rules to apply *)
+let create_new_rules word result =
+  let rules = ref []
+  and max_length = min (String.length word) (String.length result) in
+  for i = 0 to max_length - 1 do
+    match (String.get word i, String.get result i) with
+    (* A space means that the letter is not present *)
+    | c, ' ' -> rules := Criteria.NotContain (c, None) :: !rules
+    (* The same letter means that the we found the right caracter *)
+    | c, c' when Char.equal c c' ->
+        rules := Criteria.Contain (c, Some i) :: !rules
+    (* Anything else, we got the letter, but at the wrong place *)
+    | c, _ ->
+        rules :=
+          Criteria.Contain (c, None)
+          :: Criteria.NotContain (c, Some i)
+          :: !rules
+  done;
+  !rules
+
+
+let rec run filters words =
+  let () = show_structure Format.std_formatter words filters in
+  let freq = Persistence.extract_freq words in
+  let next, score = Persistence.pick_next_word words freq in
+
+  let () =
+    Format.fprintf
+      Format.std_formatter
+      "Next word will be : %s (%d)@\n"
+      next
+      score
+  in
+
+  let input = Stdlib.read_line () in
+
+  (* if the input is empty, remove the word from the list and restart *)
+  match String.equal String.empty input with
+  | true ->
+      let new_words =
+        List.filter (fun w -> not (String.equal w next)) words.element
+      in
+      run filters { words with element = new_words; number = words.number - 1 }
+  | false ->
+      let new_rules =
+        Criteria.merge_lists ~init:filters (create_new_rules next input)
+        |> List.sort_uniq Stdlib.compare
+      in
+
+      let words =
+        List.fold_left
+          (Persistence.add_word new_rules)
+          (Persistence.empty_data ())
+          words.element
+      in
+      run new_rules words
+
+
+let init_rule rules word =
+  String.iteri
+    (fun p c ->
+      match c with
+      | ' ' -> ()
+      | _ -> rules := Criteria.Contain (c, Some p) :: !rules )
+    word
+
+
+let () =
+  let length = ref 5
+  and dict = ref [] in
+  let rules = ref [] in
+
+  let anon_fun filename = dict := filename :: !dict in
+  let speclist =
+    [ ("-n", Arg.Set_int length, "Nombre de lettres")
+    ; ("-p", Arg.String (init_rule rules), "Motif initial")
+    ]
+  in
+  let () = Arg.parse speclist anon_fun "motus [-n <nb>] dictionnaire" in
+
+  let initial_filter = Criteria.Lenght !length :: !rules in
+  let words_channel = open_in (List.hd !dict) in
+  let words =
+    get_list words_channel (Persistence.empty_data ()) initial_filter
+  in
+  close_in words_channel;
+  run initial_filter words