aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--motus/bin/motus.ml41
-rw-r--r--motus/js/fieldList.ml20
-rw-r--r--motus/js/initialize.ml22
-rw-r--r--motus/js/motus.ml5
-rw-r--r--motus/js/next.ml6
-rw-r--r--motus/js/reload.ml4
-rw-r--r--motus/js/state.ml23
-rw-r--r--motus/js/updateProposition.ml2
-rw-r--r--motus/lib/dune1
-rw-r--r--motus/lib/validity.ml98
-rw-r--r--motus/lib/validity.mli20
-rw-r--r--motus/lib/wordlist.ml (renamed from motus/lib/persistence.ml)35
-rw-r--r--motus/lib/wordlist.mli (renamed from motus/lib/persistence.mli)11
-rw-r--r--motus/test/dune3
-rw-r--r--motus/test/motus_test.ml51
15 files changed, 242 insertions, 100 deletions
diff --git a/motus/bin/motus.ml b/motus/bin/motus.ml
index 0f2b17b..2ee058d 100644
--- a/motus/bin/motus.ml
+++ b/motus/bin/motus.ml
@@ -15,8 +15,7 @@ let format_filter : Format.formatter -> Criteria.t -> unit =
(** Display the informations about the structure *)
-let show_structure :
- Format.formatter -> Persistence.t -> Criteria.t list -> unit =
+let show_structure : Format.formatter -> Wordlist.t -> Criteria.t list -> unit =
fun format data filters ->
Format.fprintf
format
@@ -24,28 +23,27 @@ let show_structure :
(Format.pp_print_list format_filter)
filters;
- Format.fprintf format "Got %d elements @\n" (Persistence.list_size data);
+ Format.fprintf format "Got %d elements @\n" (Wordlist.list_size data);
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);
+ (Wordlist.extract_freq data);
- if Persistence.list_size data < 20
+ if Wordlist.list_size data < 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 ) )
- (Persistence.words data);
+ (Wordlist.words data);
Format.close_box ()
(** Get the initial list *)
-let rec get_list :
- in_channel -> Persistence.t -> Criteria.t list -> Persistence.t =
+let rec get_list : in_channel -> Wordlist.t -> Criteria.t list -> Wordlist.t =
fun channel data filters ->
let word =
try Some (String.lowercase_ascii (Stdlib.input_line channel)) with
@@ -54,7 +52,7 @@ let rec get_list :
match word with
| None -> data
| Some word ->
- let data = Persistence.add_word filters data word in
+ let data = Wordlist.add_word filters data word in
get_list channel data filters
@@ -66,24 +64,23 @@ let create_new_rules word result =
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
+ | c, ' ' -> rules := Criteria.(add (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
+ rules := Criteria.(add (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
+ Criteria.(
+ add (Contain (c, None)) (add (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 freq = Wordlist.extract_freq words in
+ let next, score = Wordlist.pick_next_word words freq in
let () =
Format.fprintf
@@ -97,7 +94,7 @@ let rec run filters words =
(* if the input is empty, remove the word from the list and restart *)
match String.equal String.empty input with
- | true -> run filters (Persistence.remove_word words next)
+ | true -> run filters (Wordlist.remove_word words next)
| false ->
let new_rules =
Criteria.merge_lists ~init:filters (create_new_rules next input)
@@ -106,9 +103,9 @@ let rec run filters words =
let words =
List.fold_left
- (Persistence.add_word new_rules)
- (Persistence.empty_data ())
- (Persistence.words words)
+ (Wordlist.add_word new_rules)
+ (Wordlist.empty_data ())
+ (Wordlist.words words)
in
run new_rules words
@@ -137,8 +134,6 @@ let () =
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
+ let words = get_list words_channel (Wordlist.empty_data ()) initial_filter in
close_in words_channel;
run initial_filter words
diff --git a/motus/js/fieldList.ml b/motus/js/fieldList.ml
index 85755aa..428f364 100644
--- a/motus/js/fieldList.ml
+++ b/motus/js/fieldList.ml
@@ -10,13 +10,13 @@ type elements = Brr.El.t list
If no class is specified, consider the letter is at the right position.
*)
-let get_validity_from_element : El.t -> State.letter_validity =
+let get_validity_from_element : El.t -> Motus_lib.Validity.t =
fun el ->
if El.class' (Jstr.v "missing") el
- then State.Missing
+ then Missing
else if El.class' (Jstr.v "misplaced") el
- then State.Misplaced
- else State.Wellplaced
+ then Misplaced
+ else Wellplaced
let get_rules : elements -> State.proposition =
@@ -32,14 +32,14 @@ let get_rules : elements -> State.proposition =
t
-let get_class : State.letter_validity -> Jstr.t = function
+let get_class : Motus_lib.Validity.t -> 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 =
+let make : int -> (int * Jstr.t * Motus_lib.Validity.t) E.send -> elements =
fun len change_sender ->
List.init ~len ~f:(fun i ->
let input =
@@ -66,9 +66,9 @@ let make : int -> (int * Jstr.t * State.letter_validity) E.send -> elements =
(fun _ ->
let validity =
match get_validity_from_element input with
- | State.Missing -> State.Misplaced
- | State.Misplaced -> State.Wellplaced
- | State.Wellplaced -> State.Missing
+ | Missing -> Motus_lib.Validity.Misplaced
+ | Misplaced -> Motus_lib.Validity.Wellplaced
+ | Wellplaced -> Motus_lib.Validity.Missing
in
change_sender (i, El.prop El.Prop.value input, validity) )
(El.as_target input);
@@ -139,7 +139,7 @@ let build : El.t -> int S.t -> State.proposition S.t =
if Jstr.equal Jstr.empty value
then (i, None)
else
- let validity = State.Wellplaced in
+ let validity = Motus_lib.Validity.Wellplaced in
(i, Some (Jstr.uppercased value, validity)) )
input )
elements
diff --git a/motus/js/initialize.ml b/motus/js/initialize.ml
index 7dd7544..82f1288 100644
--- a/motus/js/initialize.ml
+++ b/motus/js/initialize.ml
@@ -6,7 +6,7 @@ open Brr
type t =
{ length : int
; content : (int * Jstr.t, Jv.Error.t) result
- ; sender : (int * Jstr.t * State.letter_validity) E.send
+ ; sender : (int * Jstr.t * Validity.t) E.send
; proposition : State.proposition
}
@@ -16,16 +16,12 @@ type t =
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 =
+ results. *)
+let get_proposition : Wordlist.t -> Criteria.t list -> State.proposition option
+ =
fun analysis rules ->
let word =
- Persistence.extract_freq analysis
- |> Persistence.pick_next_word analysis
- |> fst
+ Wordlist.extract_freq analysis |> Wordlist.pick_next_word analysis |> fst
in
match String.equal String.empty word with
| true -> None
@@ -44,8 +40,8 @@ let get_proposition :
incr i;
let validity =
match wellplaced with
- | true -> State.Wellplaced
- | _ -> State.Missing
+ | true -> Validity.Wellplaced
+ | _ -> Validity.Missing
in
Some (Jstr.of_char c, validity) )
@@ -65,8 +61,8 @@ let process { sender; length; content; proposition } state =
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 ())
+ Wordlist.add_word rules a (Jstr.to_string upper) )
+ ~init:(Wordlist.empty_data ())
words
in
let current_prop = get_proposition analysis rules
diff --git a/motus/js/motus.ml b/motus/js/motus.ml
index a2bcbd3..402e14a 100644
--- a/motus/js/motus.ml
+++ b/motus/js/motus.ml
@@ -150,7 +150,7 @@ let main
List.map props ~f:(fun proposition ->
List.map proposition ~f:(fun prop ->
let letter, validity =
- Option.value ~default:(Jstr.empty, State.Missing) prop
+ Option.value ~default:(Jstr.empty, Validity.Missing) prop
in
let input =
El.input
@@ -173,8 +173,7 @@ let main
S.map
(fun ev ->
match
- ( ev.State.current_prop
- , Motus_lib.Persistence.list_size ev.State.analysis )
+ (ev.State.current_prop, Motus_lib.Wordlist.list_size ev.State.analysis)
with
| [], _ | _, 1 -> Some (Jstr.v "true")
| _, _ -> None )
diff --git a/motus/js/next.ml b/motus/js/next.ml
index 5f24883..72db9e4 100644
--- a/motus/js/next.ml
+++ b/motus/js/next.ml
@@ -17,9 +17,9 @@ let process : t -> State.state -> State.state =
(* 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 ())
- (Motus_lib.Persistence.words state.analysis)
+ ~f:(Motus_lib.Wordlist.add_word rules)
+ ~init:(Motus_lib.Wordlist.empty_data ())
+ (Motus_lib.Wordlist.words state.analysis)
in
let propositions = state.current_prop :: state.propositions
diff --git a/motus/js/reload.ml b/motus/js/reload.ml
index cfdfa2a..2756b74 100644
--- a/motus/js/reload.ml
+++ b/motus/js/reload.ml
@@ -18,9 +18,7 @@ let process : t -> State.state -> State.state =
in
let new_state =
- { state with
- analysis = Motus_lib.Persistence.remove_word state.analysis word
- }
+ { state with analysis = Motus_lib.Wordlist.remove_word state.analysis word }
in
(* Get the new proposition if any *)
let current_prop =
diff --git a/motus/js/state.ml b/motus/js/state.ml
index 57a3794..cbab14f 100644
--- a/motus/js/state.ml
+++ b/motus/js/state.ml
@@ -1,15 +1,10 @@
open StdLabels
open Motus_lib
-type letter_validity =
- | Wellplaced
- | Misplaced
- | Missing
-
-type proposition = (Jstr.t * letter_validity) option list
+type proposition = (Jstr.t * Validity.t) option list
type state =
- { analysis : Persistence.t
+ { analysis : Wordlist.t
; rules : Criteria.t list
; length : int
; propositions : proposition list
@@ -18,7 +13,7 @@ type state =
}
let init () =
- { analysis = Persistence.empty_data ()
+ { analysis = Wordlist.empty_data ()
; rules = []
; length = 0
; propositions = []
@@ -42,17 +37,7 @@ let get_current_rules : proposition -> Criteria.t list =
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
- )
+ rules := Validity.to_criteria char i validity !rules )
prop );
List.rev !rules
diff --git a/motus/js/updateProposition.ml b/motus/js/updateProposition.ml
index ab10db3..7a4608f 100644
--- a/motus/js/updateProposition.ml
+++ b/motus/js/updateProposition.ml
@@ -7,7 +7,7 @@ open StdLabels
type t =
{ position : int
; letter : Jstr.t
- ; validity : State.letter_validity
+ ; validity : Motus_lib.Validity.t
}
let process { position; letter; validity } state =
diff --git a/motus/lib/dune b/motus/lib/dune
index b958922..a892e2b 100644
--- a/motus/lib/dune
+++ b/motus/lib/dune
@@ -2,6 +2,7 @@
(name
motus_lib
)
+ (preprocess (pps ppx_deriving.enum))
)
diff --git a/motus/lib/validity.ml b/motus/lib/validity.ml
new file mode 100644
index 0000000..ae85f04
--- /dev/null
+++ b/motus/lib/validity.ml
@@ -0,0 +1,98 @@
+open StdLabels
+
+(* Enclose the type definition into a warning removval in order to hide some
+ auto-generated values *)
+[@@@warning "-32"]
+
+type t =
+ | Wellplaced
+ | Misplaced
+ | Missing
+[@@deriving enum]
+
+[@@@warning "+32"]
+
+let m = Float.of_int (1 + max)
+
+(** Get the index of a validity result *)
+let index_of_result : t array -> int =
+ fun elems ->
+ let _, value =
+ Array.fold_left elems ~init:(0., 0.) ~f:(fun (pos, acc) content ->
+ let v = Float.of_int (to_enum content) in
+ let acc' = acc +. (v *. (m ** pos)) in
+ (pos +. Float.one, acc') )
+ in
+ Float.to_int value
+
+
+let index_to_result : base:int -> int -> t array =
+ fun ~base n ->
+ let rec _f acc n i =
+ let next = Float.round (n /. m)
+ and rem = Float.(to_int @@ rem n m) in
+
+ match (rem, i) with
+ | _, 0 -> Array.of_list acc
+ | n, _ ->
+ ( match of_enum n with
+ | None -> Array.of_list acc
+ | Some v -> _f (v :: acc) next (i - 1) )
+ in
+ _f [] (Float.of_int n) base
+
+
+(** Build a sequence of all the possible status for a given number of letters *)
+let sequence : int -> t array Seq.t =
+ fun base ->
+ let max_element = Float.to_int @@ (m ** Float.of_int base) in
+
+ Seq.unfold
+ (fun n ->
+ if n < max_element then Some (index_to_result ~base n, n + 1) else None )
+ 0
+
+
+let compare_words : string -> ref:string -> t array option =
+ fun w1 ~ref ->
+ let l1 = String.length w1 in
+ if l1 <> String.length ref
+ then None
+ else
+ let result =
+ Array.init l1 ~f:(fun i ->
+ let c1 = String.get w1 i
+ and c2 = String.get ref i in
+
+ let state =
+ if Char.equal c1 c2
+ then Wellplaced
+ else if String.contains ref c1
+ then Misplaced
+ else Missing
+ in
+ state )
+ in
+ Some result
+
+
+let to_criteria : char -> int -> t -> Criteria.t list -> Criteria.t list =
+ fun c i t acc ->
+ match t with
+ | Wellplaced -> Criteria.add (Criteria.Contain (c, Some i)) acc
+ | Missing -> Criteria.add (Criteria.NotContain (c, None)) acc
+ | Misplaced ->
+ Criteria.add
+ (Criteria.NotContain (c, Some i))
+ (Criteria.add (Criteria.Contain (c, None)) acc)
+
+
+let to_criterias : string -> t array -> Criteria.t list =
+ fun word t ->
+ let l, _ =
+ Array.fold_left t ~init:([], 0) ~f:(fun (acc, i) t ->
+ let acc = to_criteria (String.get word i) i t acc in
+ (acc, i + 1) )
+ in
+
+ List.rev l
diff --git a/motus/lib/validity.mli b/motus/lib/validity.mli
new file mode 100644
index 0000000..dfd876c
--- /dev/null
+++ b/motus/lib/validity.mli
@@ -0,0 +1,20 @@
+type t =
+ | Wellplaced
+ | Misplaced
+ | Missing
+
+val sequence : int -> t array Seq.t
+(** Build a sequence of all the possible status for a given number of letters *)
+
+val index_of_result : t array -> int
+(** Get the index of a validity result *)
+
+val index_to_result : base:int -> int -> t array
+
+val compare_words : string -> ref:string -> t array option
+
+val to_criteria : char -> int -> t -> Criteria.t list -> Criteria.t list
+
+val to_criterias : string -> t array -> Criteria.t list
+(** Convert the validity result into a Criteria list, in the context of a given
+ word *)
diff --git a/motus/lib/persistence.ml b/motus/lib/wordlist.ml
index 6116653..45fc73a 100644
--- a/motus/lib/persistence.ml
+++ b/motus/lib/wordlist.ml
@@ -5,39 +5,34 @@ let () = Random.self_init ()
type t =
{ number : int
; element : string list
- ; freq : (char, int) Hashtbl.t
}
-let empty_data () = { number = 0; element = []; freq = Hashtbl.create 26 }
+let empty_data () = { number = 0; element = [] }
+
+let update_freq : (char, int) Hashtbl.t -> char -> unit =
+ fun freq c ->
+ match Hashtbl.find_opt freq c with
+ | None -> Hashtbl.add freq c 1
+ | Some value -> Hashtbl.replace freq c (value + 1)
+
(** Evaluate the score for each char (lower is better) *)
let extract_freq : t -> (char * int) list =
fun data ->
+ let freq = Hashtbl.create 26 in
+ List.iter data.element ~f:(fun word ->
+ String.iter word ~f:(fun c -> update_freq freq c) );
+
let number_2 = data.number / 2 in
- Hashtbl.fold (fun k v acc -> (k, abs (v - number_2)) :: acc) data.freq []
+ Hashtbl.fold (fun k v acc -> (k, abs (v - number_2)) :: acc) freq []
(* Sort the list for a pretty printing *)
|> List.sort ~cmp:(fun v1 v2 -> snd v1 - snd v2)
-let update_freq : (char, int) Hashtbl.t -> char -> unit =
- fun freq c ->
- match Hashtbl.find_opt freq c with
- | None -> Hashtbl.add freq c 1
- | Some value -> Hashtbl.replace freq c (value + 1)
-
-
let add_word : Criteria.t list -> t -> string -> t =
fun filters data word ->
match List.for_all ~f:(Criteria.check_filter word) filters with
- | true ->
- let len = String.length word in
- let chars =
- List.init ~len ~f:(fun n -> String.get word n)
- |> List.sort_uniq ~cmp:Char.compare
- in
-
- List.iter ~f:(update_freq data.freq) chars;
- { data with number = data.number + 1; element = word :: data.element }
+ | true -> { number = data.number + 1; element = word :: data.element }
| false -> data
@@ -87,7 +82,7 @@ let pick_next_word : t -> (char * int) list -> string * int =
let remove_word : t -> string -> t =
fun t word ->
let element = List.filter ~f:(fun w -> not (String.equal w word)) t.element in
- { t with element; number = t.number - 1 }
+ { element; number = t.number - 1 }
let words : t -> string list = fun { element; _ } -> element
diff --git a/motus/lib/persistence.mli b/motus/lib/wordlist.mli
index f5625e4..766fbdf 100644
--- a/motus/lib/persistence.mli
+++ b/motus/lib/wordlist.mli
@@ -7,12 +7,15 @@ val list_size : t -> int
val empty_data : unit -> t
-val extract_freq : t -> (char * int) list
-(** Evaluate the score for each char (lower is better) *)
-
val add_word : Criteria.t list -> t -> string -> t
(** Add a new word in the list. Check are made against the differents criteria in order to ensure that the word is valid *)
+val remove_word : t -> string -> t
+(** Remove a word from this list *)
+
+val extract_freq : t -> (char * int) list
+(** Evaluate the score for each char (lower is better) *)
+
val pick_next_word : t -> (char * int) list -> string * int
(** Get the word which with the most information in it.
@@ -20,5 +23,3 @@ The information is the score given to each character, representing each
frequency in the whole word list (lower is better). If the same letter is
present many times, we consider that succeding letters does not give any more
informations (do not consider the position here) *)
-
-val remove_word : t -> string -> t
diff --git a/motus/test/dune b/motus/test/dune
new file mode 100644
index 0000000..04fe199
--- /dev/null
+++ b/motus/test/dune
@@ -0,0 +1,3 @@
+(test
+ (name motus_test)
+ (libraries ounit2 motus_lib))
diff --git a/motus/test/motus_test.ml b/motus/test/motus_test.ml
new file mode 100644
index 0000000..4ea952e
--- /dev/null
+++ b/motus/test/motus_test.ml
@@ -0,0 +1,51 @@
+module Validity = Motus_lib.Validity
+open StdLabels
+open OUnit2
+
+let tests =
+ "validity test suite"
+ >::: [ ( "Sequence of elements"
+ >:: fun _ ->
+ assert_equal
+ 243
+ ( Validity.sequence 5
+ |> List.of_seq
+ |> List.sort_uniq ~cmp:Stdlib.compare
+ |> List.length ) )
+ ; ( "Index of element"
+ >:: fun _ ->
+ assert_equal 0 Validity.(index_of_result [| Wellplaced; Wellplaced |])
+ )
+ ; ( "Bijection for all the elements"
+ >:: fun _ ->
+ (* Create an array of 243 elements*)
+ let arr = Array.make 243 false in
+ let seq = Validity.sequence 5 in
+ (* Populate the array *)
+ Seq.iter
+ (fun v ->
+ let idx = Validity.index_of_result v in
+ Array.set arr idx true )
+ seq;
+
+ (* Now count the elements set to true *)
+ let count =
+ Array.fold_left arr ~init:0 ~f:(fun acc value ->
+ if value then acc + 1 else acc )
+ in
+
+ assert_equal 243 count )
+ ; ( "Compare words 1"
+ >:: fun _ ->
+ assert_equal
+ (Some Validity.[| Wellplaced; Wellplaced; Wellplaced; Wellplaced |])
+ (Validity.compare_words "Test" ~ref:"Test") )
+ ; ( "Compare words 2"
+ >:: fun _ ->
+ assert_equal
+ (Some Validity.[| Missing; Misplaced; Wellplaced |])
+ (Validity.compare_words "DAC" ~ref:"ABC") )
+ ]
+
+
+let _ = run_test_tt_main tests
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 15:14:30 +0000