summaryrefslogtreecommitdiff
path: root/motus/bin
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@dailly.me>2022-01-28 14:44:57 +0100
committerSébastien Dailly <sebastien@dailly.me>2022-02-07 16:22:43 +0100
commit741f88ab405995003eb6e9f301d3b065c1e84a4a (patch)
tree08ba9ec2247c56680611d542ed9b096c5f1a083b /motus/bin
parentc0c82a7bfe8300b1bd50fee11074837ff32d3da0 (diff)
Added a motus solver
Diffstat (limited to 'motus/bin')
-rw-r--r--motus/bin/dune7
-rw-r--r--motus/bin/motus.ml148
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