mbarbin / super-master-mind / 176

Committed 16 Dec 2025 01:25PM UTC coverage: 92.007% (-4.3%) from 96.355%

Build # 176

Build Type

Pull #33

github

Committed by

web-flow

Commit Message

Merge 2ac713a42 into 9cd937d49

Pull Request Pull Request #33: Use json format for opening-book

Run Details

420 of 491 new or added lines in 28 files covered. (85.54%)

2 existing lines in 1 file now uncovered.

1013 of 1101 relevant lines covered (92.01%)

3377900.1 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

93.65

/src/opening_book.ml

(*********************************************************************************)
(*  super-master-mind: A solver for the super master mind game                   *)
(*  SPDX-FileCopyrightText: 2021-2025 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
(*  SPDX-License-Identifier: MIT                                                 *)
(*********************************************************************************)

type t = Guess.t

let to_json = Guess.to_json
let of_json = Guess.of_json
let root t ~color_permutation = Guess.map_color t ~color_permutation

let rec compute_internal
          (t : t)
          ~display
          ~task_pool
          ~possible_solutions
          ~current_depth
          ~depth
          ~k
  =
  let number_of_cue = Nonempty_list.length t.by_cue in
  let bar =
    let open Progress.Line in
    list
      [ bar number_of_cue
      ; count_to number_of_cue
      ; parens (const "eta: " ++ eta number_of_cue)
      ]
  in
  let reporter = Progress.Display.add_line display bar in
  let by_cue =
    Nonempty_list.map t.by_cue ~f:(fun c ->
      (* For each cue, we compute the best k candidate. *)
      let possible_solutions =
        Codes.filter possible_solutions ~candidate:t.candidate ~cue:c.cue
      in
      let next_best_guesses =
        Guess.compute_k_best ~display ~task_pool ~possible_solutions ~k ()
      in
      let next_best_guesses =
        if current_depth < depth
        then
          List.map next_best_guesses ~f:(fun t ->
            compute_internal
              t
              ~display
              ~task_pool
              ~possible_solutions
              ~current_depth:(Int.succ current_depth)
              ~depth
              ~k)
        else next_best_guesses
      in
      Progress.Reporter.report reporter 1;
      { c with next_best_guesses = Computed next_best_guesses })
  in
  Progress.Reporter.finalise reporter;
  Progress.Display.remove_line display reporter;
  { t with by_cue }
;;

let canonical_first_candidate =
  lazy
    (Array.init (force Code.size) ~f:Fn.id
     |> Array.map ~f:Color.of_index_exn
     |> Array.map ~f:Color.to_hum
     |> Code.create_exn)
;;

let compute ~task_pool ~depth =
  if depth < 1 then Code_error.raise "depth >= 1 expected." [ "depth", Dyn.int depth ];
  let display =
    Progress.Display.start
      ~config:(Progress.Config.v ~persistent:false ())
      (Progress.Multi.lines [])
  in
  let possible_solutions = Codes.all in
  let t =
    Guess.compute ~possible_solutions ~candidate:(force canonical_first_candidate)
  in
  let t =
    compute_internal
      t
      ~display
      ~task_pool
      ~possible_solutions
      ~current_depth:1
      ~depth
      ~k:1
  in
  Progress.Display.finalise display;
  t
;;

let depth =
  let rec aux (t : Guess.t) =
    Nonempty_list.fold t.by_cue ~init:0 ~f:(fun acc t -> Int.max acc (aux_by_cue t))
  and aux_by_cue (t : Guess.By_cue.t) =
    match t.next_best_guesses with
    | Not_computed -> 0
    | Computed ts -> 1 + List.fold ts ~init:0 ~f:(fun acc t -> Int.max acc (aux t))
  in
  aux
;;

let find_opening_book_via_site () =
  List.find_map Sites.Sites.opening_book ~f:(fun dir ->
    let file = Stdlib.Filename.concat dir "opening-book.json" in
    Option.some_if (Stdlib.Sys.file_exists file) file)
;;

let opening_book =
  lazy
    (let file = find_opening_book_via_site () |> Option.get in
     Json.load ~file |> of_json)
;;

let dump_cmd =
  Command.make
    ~summary:"Dump the installed opening-book."
    (let open Command.Std in
     let+ () = Arg.return () in
     let t = Lazy.force opening_book in
     Stdlib.print_endline (t |> to_json |> Json.to_string))
;;

let compute_cmd =
  Command.make
    ~summary:"Compute and save the opening-book."
    (let open Command.Std in
     let+ () = Game_dimensions.arg (Source_code_position.of_pos Stdlib.__POS__)
     and+ depth =
       Arg.named_with_default
         [ "depth" ]
         Param.int
         ~default:2
         ~doc:"Specify the depth of the opening-book."
     and+ task_pool_config = Task_pool.Config.arg
     and+ path =
       Arg.named
         [ "output-file"; "o" ]
         Param.string
         ~docv:"FILE"
         ~doc:"Save output to file."
     in
     Task_pool.with_t task_pool_config ~f:(fun ~task_pool ->
       let t = compute ~task_pool ~depth in
       Json.save (to_json t) ~file:path))
;;

let verify_cmd =
  Command.make
    ~summary:"Verify properties of the installed opening-book."
    (let open Command.Std in
     let+ color_permutation =
       let+ v =
         Arg.named_opt
           [ "color-permutation" ]
           Color_permutation.param
           ~doc:"Color permutation in [0; 40319] (default Identity)."
       in
       match v with
       | Some color_permutation -> color_permutation
       | None -> force Color_permutation.identity
     in
     let t = root (Lazy.force opening_book) ~color_permutation in
     match Guess.verify t ~possible_solutions:Codes.all with
     | Ok () -> ()
     | Error error ->
       Stdlib.prerr_endline "Installed opening-book does not verify expected properties.";
       Guess.Verify_error.print_hum error Out_channel.stderr;
       Stdlib.exit 1)
;;

let cmd =
  Command.group
    ~summary:"Opening pre computation (aka the 'opening-book')."
    [ "dump", dump_cmd; "compute", compute_cmd; "verify", verify_cmd ]
;;

1	(*********************************************************************************)
2	(* super-master-mind: A solver for the super master mind game *)
3	(* SPDX-FileCopyrightText: 2021-2025 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* SPDX-License-Identifier: MIT *)
5	(*********************************************************************************)
6
7	type t = Guess.t
8
9	let to_json = Guess.to_json
10	let of_json = Guess.of_json
11	let root t ~color_permutation = Guess.map_color t ~color_permutation	11✔
12
13	let rec compute_internal
14	(t : t)
15	~display
16	~task_pool
17	~possible_solutions
18	~current_depth
19	~depth
20	~k
21	=
22	let number_of_cue = Nonempty_list.length t.by_cue in	8✔
23	let bar =	8✔
24	let open Progress.Line in
25	list	8✔
26	[ bar number_of_cue	8✔
27	; count_to number_of_cue	8✔
28	; parens (const "eta: " ++ eta number_of_cue)	8✔
29	]
30	in
31	let reporter = Progress.Display.add_line display bar in
32	let by_cue =	8✔
33	Nonempty_list.map t.by_cue ~f:(fun c ->
34	(* For each cue, we compute the best k candidate. *)
35	let possible_solutions =	48✔
36	Codes.filter possible_solutions ~candidate:t.candidate ~cue:c.cue
37	in
38	let next_best_guesses =	48✔
39	Guess.compute_k_best ~display ~task_pool ~possible_solutions ~k ()
40	in
41	let next_best_guesses =	48✔
42	if current_depth < depth
43	then
44	List.map next_best_guesses ~f:(fun t ->	9✔
45	compute_internal	7✔
46	t
47	~display
48	~task_pool
49	~possible_solutions
50	~current_depth:(Int.succ current_depth)	7✔
51	~depth
52	~k)
53	else next_best_guesses	39✔
54	in
55	Progress.Reporter.report reporter 1;
56	{ c with next_best_guesses = Computed next_best_guesses })	48✔
57	in
58	Progress.Reporter.finalise reporter;	8✔
59	Progress.Display.remove_line display reporter;	8✔
60	{ t with by_cue }	8✔
61	;;
62
63	let canonical_first_candidate =
64	lazy
65	(Array.init (force Code.size) ~f:Fn.id	1✔
66	\|> Array.map ~f:Color.of_index_exn	1✔
67	\|> Array.map ~f:Color.to_hum	1✔
68	\|> Code.create_exn)	1✔
69	;;
70
71	let compute ~task_pool ~depth =
NEW 72	if depth < 1 then Code_error.raise "depth >= 1 expected." [ "depth", Dyn.int depth ];	×
73	let display =	1✔
74	Progress.Display.start
75	~config:(Progress.Config.v ~persistent:false ())	1✔
76	(Progress.Multi.lines [])	1✔
77	in
78	let possible_solutions = Codes.all in	1✔
79	let t =
80	Guess.compute ~possible_solutions ~candidate:(force canonical_first_candidate)	1✔
81	in
82	let t =
83	compute_internal
84	t
85	~display
86	~task_pool
87	~possible_solutions
88	~current_depth:1
89	~depth
90	~k:1
91	in
92	Progress.Display.finalise display;	1✔
93	t	1✔
94	;;
95
96	let depth =
97	let rec aux (t : Guess.t) =
98	Nonempty_list.fold t.by_cue ~init:0 ~f:(fun acc t -> Int.max acc (aux_by_cue t))	259✔
99	and aux_by_cue (t : Guess.By_cue.t) =
100	match t.next_best_guesses with	2,925✔
101	\| Not_computed -> 0	2,651✔
102	\| Computed ts -> 1 + List.fold ts ~init:0 ~f:(fun acc t -> Int.max acc (aux t))	258✔
103	in
104	aux
105	;;
106
107	let find_opening_book_via_site () =
108	List.find_map Sites.Sites.opening_book ~f:(fun dir ->	8✔
109	let file = Stdlib.Filename.concat dir "opening-book.json" in	8✔
110	Option.some_if (Stdlib.Sys.file_exists file) file)	8✔
111	;;
112
113	let opening_book =
114	lazy
115	(let file = find_opening_book_via_site () \|> Option.get in	8✔
116	Json.load ~file \|> of_json)	8✔
117	;;
118
119	let dump_cmd =
120	Command.make	19✔
121	~summary:"Dump the installed opening-book."
122	(let open Command.Std in
123	let+ () = Arg.return () in	19✔
124	let t = Lazy.force opening_book in	1✔
125	Stdlib.print_endline (t \|> to_json \|> Json.to_string))	1✔
126	;;
127
128	let compute_cmd =
129	Command.make	19✔
130	~summary:"Compute and save the opening-book."
131	(let open Command.Std in
132	let+ () = Game_dimensions.arg (Source_code_position.of_pos Stdlib.__POS__)	19✔
133	and+ depth =
134	Arg.named_with_default	19✔
135	[ "depth" ]
136	Param.int
137	~default:2
138	~doc:"Specify the depth of the opening-book."
139	and+ task_pool_config = Task_pool.Config.arg
140	and+ path =
141	Arg.named	19✔
142	[ "output-file"; "o" ]
143	Param.string
144	~docv:"FILE"
145	~doc:"Save output to file."
146	in
147	Task_pool.with_t task_pool_config ~f:(fun ~task_pool ->	1✔
148	let t = compute ~task_pool ~depth in	1✔
149	Json.save (to_json t) ~file:path))	1✔
150	;;
151
152	let verify_cmd =
153	Command.make	19✔
154	~summary:"Verify properties of the installed opening-book."
155	(let open Command.Std in
156	let+ color_permutation =
157	let+ v =
158	Arg.named_opt	19✔
159	[ "color-permutation" ]
160	Color_permutation.param
161	~doc:"Color permutation in [0; 40319] (default Identity)."
162	in
163	match v with	2✔
164	\| Some color_permutation -> color_permutation	1✔
165	\| None -> force Color_permutation.identity	1✔
166	in
167	let t = root (Lazy.force opening_book) ~color_permutation in	2✔
168	match Guess.verify t ~possible_solutions:Codes.all with	2✔
169	\| Ok () -> ()	2✔
170	\| Error error ->	×
171	Stdlib.prerr_endline "Installed opening-book does not verify expected properties.";
172	Guess.Verify_error.print_hum error Out_channel.stderr;	×
173	Stdlib.exit 1)	×
174	;;
175
176	let cmd =
177	Command.group	19✔
178	~summary:"Opening pre computation (aka the 'opening-book')."
179	[ "dump", dump_cmd; "compute", compute_cmd; "verify", verify_cmd ]
180	;;

mbarbin / super-master-mind / 176

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous