K3x10

src/cli.ml

@@ -37,8 +37,7 @@ module Worker = struct
     let module Stats = Stats.Make (Incr) (Layout) in
     let module Score = Score.Make (Incr) (Layout) (Stats) in
     let module Gen = Gen.Make (Incr) (Layout) (Stats) (Score) in
-    let corpus = Corpus.load_corpus corpus in
-    let layout = Layout.ansi () in
+    let layout = Layout.k3x10 () in
     Layout.scramble layout 30;
     let stats = Stats.make layout corpus in
     let score = Score.default_config stats in
@@ -113,6 +112,7 @@ let cmd =
         (optional_with_default Default.threads int)
         ~doc:(sprintf "INT Number of threads to use. Default: %d" Default.threads)
     in
+    let corpus = Corpus.load_corpus corpus in
     fun () ->
       match threads with
       | 1 -> main_single ~corpus

src/corpus.ml

@@ -15,24 +15,30 @@ type t =
   }
 [@@deriving sexp]
 
-let load_corpus name =
-  let data =
-    In_channel.read_all name
-    (* (match Sites.Sites.corpus with
-       | [ path ] -> path ^/ name
-       | _ -> failwith "No path to corpus") *)
+let merge =
+  let m s1 s2 =
+    Hashtbl.merge s1 s2 ~f:(fun ~key:_ data ->
+      Some
+        (match data with
+         | `Both (a, b) -> a +. b
+         | `Left a | `Right a -> a))
   in
-  let sexp = Sexp.of_string data in
-  t_of_sexp sexp
-;;
-
-let n tbl =
-  let total = List.sum (module Float) (Hashtbl.data tbl) ~f:Fn.id in
-  Hashtbl.map tbl ~f:(fun v -> v /. total)
+  fun t1 t2 ->
+    { s1 = m t1.s1 t2.s1
+    ; s2 = m t1.s2 t2.s2
+    ; s3 = m t1.s3 t2.s3
+    ; s4 = m t1.s4 t2.s4
+    ; s5 = m t1.s5 t2.s5
+    ; s6 = m t1.s6 t2.s6
+    ; s7 = m t1.s7 t2.s7
+    ; s8 = m t1.s8 t2.s8
+    ; s9 = m t1.s9 t2.s9
+    ; singles = m t1.singles t2.singles
+    ; triples = m t1.triples t2.triples
+    }
 ;;
 
-let of_string s =
-  let len = String.length s in
+let empty () =
   let singles = Char.Table.create () in
   let triples = String.Table.create () in
   let s1 = String.Table.create () in
@@ -44,46 +50,95 @@ let of_string s =
   let s7 = String.Table.create () in
   let s8 = String.Table.create () in
   let s9 = String.Table.create () in
-  let sn = [| s1; s2; s3; s4; s5; s6; s7; s8; s9 |] in
-  let sn_len = Array.length sn in
-  for i = 0 to len - 1 do
-    let c1 = Char.lowercase s.[i] in
-    Hashtbl.update singles c1 ~f:(function
-      | Some v -> v +. 1.
-      | None -> 1.);
-    for j = 0 to sn_len - 1 do
-      if i + j + 1 < len
-      then (
-        let c2 = Char.lowercase s.[i + j + 1] in
-        if i + j + 2 < len
+  { s1; s2; s3; s4; s5; s6; s7; s8; s9; singles; triples }
+;;
+
+let n tbl =
+  let total = List.sum (module Float) (Hashtbl.data tbl) ~f:Fn.id in
+  Hashtbl.map tbl ~f:(fun v -> v /. total)
+;;
+
+let of_string s =
+  let len = String.length s in
+  let worker p q =
+    let singles = Char.Table.create () in
+    let triples = String.Table.create () in
+    let s1 = String.Table.create () in
+    let s2 = String.Table.create () in
+    let s3 = String.Table.create () in
+    let s4 = String.Table.create () in
+    let s5 = String.Table.create () in
+    let s6 = String.Table.create () in
+    let s7 = String.Table.create () in
+    let s8 = String.Table.create () in
+    let s9 = String.Table.create () in
+    let sn = [| s1; s2; s3; s4; s5; s6; s7; s8; s9 |] in
+    let sn_len = Array.length sn in
+    let lowercase = Char.lowercase in
+    for i = p to q - 1 do
+      if i mod 1000000 = 0
+      then
+        printf
+          "%d/%d = %f\n%!"
+          (i - p)
+          (q - p - 1)
+          (Float.of_int (i - p) /. Float.of_int (q - p - 1) *. 100.);
+      let c1 = lowercase s.[i] in
+      Hashtbl.update singles c1 ~f:(function
+        | Some v -> v +. 1.
+        | None -> 1.);
+      for j = 0 to sn_len - 1 do
+        if i + j + 1 < len
         then (
-          let c3 = Char.lowercase s.[i + j + 2] in
-          Hashtbl.update
-            triples
-            (String.of_char_list [ c1; c2; c3 ])
-            ~f:(function
-              | Some v -> v +. 1.
-              | None -> 1.);
-          Hashtbl.update
-            sn.(j)
-            (String.of_char_list [ c1; c2 ])
-            ~f:(function
-              | Some v -> v +. 1.
-              | None -> 1.)))
-    done
-  done;
+          let c2 = lowercase s.[i + j + 1] in
+          if i + j + 2 < len
+          then (
+            let c3 = lowercase s.[i + j + 2] in
+            Hashtbl.update
+              triples
+              (String.of_char_list [ c1; c2; c3 ])
+              ~f:(function
+                | Some v -> v +. 1.
+                | None -> 1.);
+            Hashtbl.update
+              sn.(j)
+              (String.of_char_list [ c1; c2 ])
+              ~f:(function
+                | Some v -> v +. 1.
+                | None -> 1.)))
+      done
+    done;
+    { s1; s2; s3; s4; s5; s6; s7; s8; s9; singles; triples }
+  in
+  let num_domains = Domain.recommended_domain_count () - 1 in
+  let width = len / num_domains in
+  let module T = Domainslib.Task in
+  let pool = T.setup_pool ~num_domains () in
+  let res =
+    T.run pool (fun () ->
+      Domainslib.Task.parallel_for_reduce
+        ~start:0
+        ~finish:num_domains
+        ~body:(fun domain ->
+          let p = domain * width in
+          let q = Int.min (p + width) len in
+          worker p q)
+        pool
+        merge
+        (empty ()))
+  in
   let res =
-    { s1 = n s1
-    ; s2 = n s2
-    ; s3 = n s3
-    ; s4 = n s4
-    ; s5 = n s5
-    ; s6 = n s6
-    ; s7 = n s7
-    ; s8 = n s8
-    ; s9 = n s9
-    ; singles = n singles
-    ; triples = n triples
+    { s1 = n res.s1
+    ; s2 = n res.s2
+    ; s3 = n res.s3
+    ; s4 = n res.s4
+    ; s5 = n res.s5
+    ; s6 = n res.s6
+    ; s7 = n res.s7
+    ; s8 = n res.s8
+    ; s9 = n res.s9
+    ; singles = n res.singles
+    ; triples = n res.triples
     }
   in
   let same =
@@ -93,9 +148,27 @@ let of_string s =
     String.equal s s'
   in
   if not same then failwith "not same";
+  T.teardown_pool pool;
   res
 ;;
 
+let load_corpus name =
+  let data =
+    In_channel.read_all name
+    (* (match Sites.Sites.corpus with
+       | [ path ] -> path ^/ name
+       | _ -> failwith "No path to corpus") *)
+  in
+  if not (String.is_suffix name ~suffix:".sexp")
+  then (
+    let res = of_string data in
+    let () = sexp_of_t res |> Sexp.save (name ^ ".sexp") in
+    res)
+  else (
+    let sexp = Sexp.of_string data in
+    t_of_sexp sexp)
+;;
+
 module Lookup = struct
   let freq1 c1 ~data =
     match c1 with

src/gen.ml

@@ -20,6 +20,8 @@ struct
     ; save_state : Layout.save_state
     }
 
+  let i = ref 0
+
   let acceptance_probability old_cost new_cost temperature =
     let ( < ) = Float.( < ) in
     let res =
@@ -36,13 +38,15 @@ struct
                    )
                    +. 1.)))
     in
-    (* if new_cost < old_cost && Random.int 10 = 1
+    (* if new_cost < old_cost && Random.int 100000 = 1
        then
        printf
-       "%.20f\t%.20f\t%.12f\n%!"
+       "%d\t%.20f\t%.20f\t%.12f\n%!"
+       !i
        new_cost
        ((old_cost -. new_cost) /. temperature)
        temperature; *)
+    incr i;
     res
   ;;
 
@@ -112,8 +116,8 @@ struct
     in
     let initial_solution = Layout.save layout in
     let initial_temperature = 100.0 in
-    let cooling_rate = 0.9997 in
-    let num_iterations = 1_00_000 in
+    let cooling_rate = 0.999998 in
+    let num_iterations = 1_000_000 in
     (* let num_iterations = 0 in *)
     let best_solution, best_cost =
       simulated_annealing
@@ -147,7 +151,7 @@ struct
     while !continue_ do
       continue_ := false;
       incr iteration;
-      printf "Brute Force Round %d...\n%!" !iteration;
+      (* printf "Brute Force Round %d...\n%!" !iteration; *)
       let save_states =
         let seen = ref SS.Set.empty in
         (match mode with
@@ -178,7 +182,7 @@ struct
            done);
         Set.to_list !seen
       in
-      printf "Seen: %d...\n%!" (List.length save_states);
+      (* printf "Seen: %d...\n%!" (List.length save_states); *)
       let current_best_score, current_best_save_state =
         save_states
         |> List.mapi ~f:(fun _i save_state ->
@@ -195,12 +199,12 @@ struct
       then (
         continue_ := true;
         best_save_state := current_best_save_state;
-        best_score := current_best_score;
-        printf
-          "Brute Force Round %d Improvement...\n%f\n%s\n%!"
-          !iteration
-          !best_score
-          (Layout.pretty_string layout));
+        best_score := current_best_score
+        (* printf
+           "Brute Force Round %d Improvement...\n%f\n%s\n%!"
+           !iteration
+           !best_score
+           (Layout.pretty_string layout) *));
       Layout.load layout !best_save_state
     done;
     Incr.stabilize ();