Source file boltzgen.ml

module Runtime = struct
  module Type = Type
  open Type

  type nat = int
  type natp = int
  type bits = int
  type small_nat = int
  type simple_string = string
  type simple_spaced_string = string
  type id_string = string

  let _ = Type_lib.fill_type_lib ()
  let parse_string = Parse_from_compiler.parse_string
  let send_warning = ref false

  let compute_boltzman ?(silent = false) intype target =
    let open Recursive_type_gen in
    let equations = equations_from_compo intype [] in
    if !verbose > 1 then
      Format.printf "%a@." Solve_lineq.print_equations (Array.of_list equations);
    let simple_type_boltz bt z =
      match bt with
      | Name (n, _) ->
          if (find_type n).is_simple then Some (boltzman_from_compo bt z)
          else None
      | Abstract _ -> Some (boltzman_from_compo (Name ("int", [])) z)
      | _ -> None
    in

    let size_of_res z res =
      List.iter
        (fun (t1, v, dv) -> Recursive_type_gen.add_memoize t1 z (v, dv))
        res;
      let nv, dnv = boltzman_from_compo intype z in
      z *. dnv /. nv
    in

    let comp_z z =
      match Solve_lineq.compute_size simple_type_boltz equations z with
      | Some res -> (res, size_of_res z res)
      | None -> failwith "fail to compute weigth"
    in

    (*let x = newton_raphson_iterate ~bound:(0.0,1.0) (fun y -> let (x,dx) = boltzman_from_compo intype y in x-.init,dx) 0.001 in*)
    let res, z =
      match
        let z_prop =
          Math.dichotomie ~verbose:!verbose ~up_bound:false ~low:(0.0, 0.0)
            (0.0, 1.0)
            (fun z ->
              match Solve_lineq.compute_size simple_type_boltz equations z with
              | None -> (nan, nan)
              | Some res -> (size_of_res z res, 0.0))
            target
        in
        (Solve_lineq.compute_size simple_type_boltz equations z_prop, z_prop)
      with
      | Some res, z -> (res, z)
      | None, _ ->
          (* target not accessible *)
          let _, esmin = comp_z 1e-16 in
          let res, esone = comp_z 1.0 in
          if not (!send_warning || silent) then (
            Format.eprintf
              "Fail to reach target %g. Closest is %g for z=0 continue with \
               z=1, size=%g@."
              target esmin esone;
            send_warning := true);
          (res, 1.0)
      | exception Math.Not_converging (_, maxv) ->
          let _, esmin = comp_z 1e-16 in
          let res, esone = comp_z 1.0 in
          (* target not accessible *)
          if not (!send_warning || silent) then (
            Format.eprintf
              "Fail to reach target %g. Range is ]%g,%g[ continue with z=1, \
               size=%g@."
              target esmin maxv esone;
            send_warning := true);
          (res, 1.0)
    in

    List.iter
      (fun (t1, v, dv) -> Recursive_type_gen.add_memoize t1 z (v, dv))
      res;

    (*let x = init in*)
    let nv, dnv = boltzman_from_compo intype z in
    let es = z *. dnv /. nv in
    if !verbose > 0 then
      Format.printf "Boltzman -> obj:%g type:'%a' : z:%g -> G:%g E:%g\n" target
        (pp_compo ~use_boltz_id:false)
        intype z nv es;
    (z, nv, es)

  let max_size = ref 20
  let boltzmann_size = ref 5.0
  let set_max_size m = max_size := m
  let set_boltzmann_size b = boltzmann_size := b
  let random_state () = Random.State.make [| Random.bits () |]

  (** Function usefull at runtime *)

  let print_value f t v =
    let td =
      match Parse_from_compiler.parse_string ("val r:" ^ t) with
      | _, Some x -> x
      | _ -> failwith "No function defined"
    in
    let bt = ano_func td in
    Recursive_type_gen.print_from_compo bt f (hide v bt)

  let rand_value ?seed ?size ?silent t =
    let td =
      match Parse_from_compiler.parse_string ("val r:" ^ t) with
      | _, Some x -> x
      | _ -> failwith "No function defined"
    in
    let bt = ano_func td in
    let z, _, _ =
      compute_boltzman ?silent td.outtype
        (Option.value ~default:!boltzmann_size size)
    in
    let rs =
      Random.State.make [| Option.value ~default:(Random.bits ()) seed |]
    in
    let vr, _ = Recursive_type_gen.gen_from_compo rs !max_size bt z in
    reveal vr bt

  let rand_fun ?size ?silent t seed l =
    let f = rand_value ~seed ?size ?silent t in
    (f : 'a) l

  let rand_fun_alea ?seed ?size ?silent t l =
    let f = rand_value ?seed ?size ?silent t in
    (f : 'a) l

  let eval_typedef s =
    Recursive_type_gen.evaluate @@ Parse_from_compiler.parse_typedef s

  let evaluate = Recursive_type_gen.evaluate
  let gen_string_of_compo = Recursive_type_gen.gen_string_of_compo []

  type random_fun_table =
    (Type.compo_type list * Type.compo_type, char) Hashtbl.t

  (* if bt is a function generate it otherwise do nothing *)
  let gen_random_fun_def_compo hash f bt =
    match bt with
    | Fun (l, ofun) -> (
        match Hashtbl.find_opt hash (l, ofun) with
        | Some _ -> ()
        | None ->
            let id = char_of_int (97 + Hashtbl.length hash) in
            Hashtbl.add hash (l, ofun) id;
            let fn, tpl, _ =
              (*name each arg and make a tuple i.e. uncurry  *)
              List.fold_left
                (fun (a, a2, i) _ ->
                  ( a ^ Printf.sprintf " %c" (char_of_int i),
                    a2
                    ^ Printf.sprintf "%s%c"
                        (if a2 <> "" then "," else "")
                        (char_of_int i),
                    i + 1 ))
                ("", "", 97) l
            in
            Format.fprintf f "let fun_%c seed%s = rand_fun \"%a\" seed (%s)@."
              id fn Type.pp_type_of_out bt tpl)
    | _ -> ()

  let gen_random_fun_def out defl hash f =
    List.iter (Format.fprintf out "let _ = eval_typedef \"%a\"@." pp_def) defl;
    Format.pp_print_list (gen_random_fun_def_compo hash) out f.intypes

  let call_random = Recursive_type_gen.call_random
  let gen_from_compo = Recursive_type_gen.gen_from_compo
  let print_from_compo = Recursive_type_gen.print_from_compo
  let stagfun_struct = Recursive_type_gen.stagfun_struct
  let nb_test = ref 0
  let nb_fail = ref 0

  let assert_equal ?(throw = false) ?(err = true) to_string1 to_string2 arg v1
      v2 =
    ignore throw;
    incr nb_test;
    let s1 = try to_string1 (v1 ()) with _ -> "Exception occurs"
    and s2 = try to_string2 (v2 ()) with _ -> "Exception occurs" in
    if s1 <> s2 then (
      incr nb_fail;
      if err then Printf.eprintf "%s = %s instead of %s\n" arg s1 s2
      else Printf.printf "%s = %s instead of %s\n" arg s1 s2;
      exit 1)

  let assert_equal_arg ?throw ?(err = true) to_string1 to_string2 to_string_arg
      f1 f2 arg =
    assert_equal ?throw ~err to_string1 to_string2 (to_string_arg arg)
      (fun () -> f1 arg)
      (fun () -> f2 arg)

  let assert_equal_string ?(err = true) arg v1 v2 =
    incr nb_test;
    let s1 = v1 () and s2 = v2 () in
    if s1 <> s2 then (
      incr nb_fail;
      if err then Printf.eprintf "%s = %s instead of %s\n" arg s1 s2
      else Printf.printf "%s = %s instead of %s\n" arg s1 s2;
      exit 1)
end

module Generator_loop = struct
  open Runtime.Type

  let mname_of_string s =
    let sm =
      match String.rindex_opt s '/' with
      | None -> s
      | Some i -> String.sub s (i + 1) (String.length s - i - 1)
    in
    let s2 = String.sub sm 1 (String.length sm - 1) in
    let s3 =
      match String.index_opt s2 '.' with
      | None -> s2
      | Some i -> String.sub s2 0 i
    in
    let c2 = Char.escaped @@ Char.uppercase_ascii @@ sm.[0] in
    c2 ^ s3

  let print_typedef f l =
    Format.pp_print_list (fun _ x -> Format.fprintf f "\t%a@." pp_def x) f l

  let print_sig f (named, func) =
    (*if named <> [] then Printf.fprintf f "module Ctype = struct \n%a\nend\n" print_typedef named;*)
    Format.fprintf f "module type EXPSIG = sig@.%a\t%a@.end" print_typedef named
      (fun f -> pp_func f)
      func

  let gen_to_string ?(throw = false) ?canonize f =
    let ts = Runtime.gen_string_of_compo (*[]*) f.outtype in
    match (throw, canonize) with
    | true, Some x ->
        Printf.sprintf "fun v -> try %s (%s v) with x -> Printexc.to_string x"
          ts x
    | true, None -> Printf.sprintf "try %s with x -> Printexc.to_string x" ts
    | false, Some x -> Printf.sprintf "fun v -> %s (%s v)" ts x
    | false, None -> ts

  let generic_loop header call footer ?(out_err = false) ?tsrange ?throw
      ?canonize ?boltz_evaluated out_file size n t files =
    Runtime.set_boltzmann_size size;
    let td, func, z =
      match boltz_evaluated with
      | None ->
          let td, funcopt = Runtime.parse_string t in
          let func =
            match funcopt with
            | None -> failwith "No function defined"
            | Some x -> x
          in
          List.iter Runtime.evaluate td;
          let intype = Prod func.intypes in
          let z, _, _ = Runtime.compute_boltzman intype size in
          (td, func, z)
      | Some x -> x
    in
    let max = int_of_float size in
    let randfun = Hashtbl.create 42 in
    let rs = Runtime.random_state () in
    let ts = gen_to_string ?throw ?canonize func in
    let sigs out () = print_sig out (td, func) in
    let random_fun_def out () =
      Runtime.gen_random_fun_def out td randfun func
    in
    header out_file ~out_err max func sigs ts random_fun_def;
    for i = 1 to n do
      let j = 2 + (i * (max - 2) / n) in
      let s = Runtime.call_random ?tsrange randfun rs j z func in
      call out_file ~out_err ?throw ?canonize s
    done;
    footer out_file files

  let gen_value ?tsrange:_ ~boltz_evaluated:(_, func, z) out_file max n =
    let rs = Runtime.random_state () in
    for _ = 1 to n do
      let ht, _ = Runtime.gen_from_compo rs (int_of_float max) func z in
      Runtime.print_from_compo func out_file ht;
      Format.pp_print_newline out_file ()
    done

  let gen_header size out_file ~out_err:_ _ _ sigs ts random_fun_def =
    Format.fprintf out_file
      "open Boltzgen.Runtime@.let _ = set_max_size %i;\n\
       set_boltzmann_size %f;;@.%a@.module TestFunctor (R : EXPSIG ) = \
       struct@.\topen R@.\tlet to_string = %s@.       %a\tlet _ =@."
      (int_of_float size) !Runtime.boltzmann_size sigs () ts random_fun_def ()

  let gen_test ?(out_err = false) ?(ftotest = "rendu.ml") ?tsrange
      ?boltz_evaluated file_name size n t =
    generic_loop (gen_header size)
      (fun out_file ~out_err ?throw:_ ?canonize:_ s ->
        Format.fprintf out_file
          "\t\t%s (\"%s = \"^(try to_string (%s) with x -> Printexc.to_string \
           x)^\"\");\n"
          (if out_err then "prerr_endline" else "print_endline")
          (String.escaped s) s)
      (fun out_file _ ->
        Format.fprintf out_file
          "\t\t()\nend;;\n#mod_use \"%s\"\nmodule TA = TestFunctor (%s);;"
          ftotest (mname_of_string ftotest))
      ~out_err ?tsrange ?boltz_evaluated file_name size n t ftotest

  let gen_test_direct ?(out_err = false) ?throw ?canonize ?boltz_evaluated
      file_name size n t =
    generic_loop
      (fun out_file ~out_err:_ _ _ sigs ts random_fun_def ->
        Format.fprintf out_file
          "open Boltzgen.Runtime\n\
           let _ = set_max_size %i;\n\
           set_boltzmann_size %f;;\n\
           %a\n\
           let to_string = %s\n\
           %a;;\n"
          (int_of_float size) !Runtime.boltzmann_size sigs () ts random_fun_def
          ())
      (fun out_file ~out_err ?throw:_ ?canonize:_ s ->
        Format.fprintf out_file
          "\t\t%s (\"%s = \"^(try to_string (%s) with x -> Printexc.to_string \
           x)^\"\");\n"
          (if out_err then "prerr_endline" else "print_endline")
          (String.escaped s) s)
      (fun out_file _ -> Format.fprintf out_file "\t\t();;\n")
      ~out_err ?throw ?canonize ?boltz_evaluated file_name size n t ()

  let gen_test_diff ?(out_err = false) ?tsrange ?throw ?canonize
      ?boltz_evaluated r1 r2 file_name max n t =
    generic_loop
      (fun out_file ~out_err _ _ sigs ts random_fun_def ->
        Format.fprintf out_file
          "open Boltzgen.Runtime\n\
           %a\n\
           module TestFunctorDiff (R1 : EXPSIG) (R2 : EXPSIG) = struct\n\
           \tlet to_string1 = let open R1 in %s\n\
           \tlet to_string2 = let open R2 in %s\n\
           \tlet ae = assert_equal %s to_string1 to_string2\n\
           %a\tlet _ = \n"
          sigs () ts ts
          (if out_err then "" else "~err:true")
          random_fun_def ())
      (fun out_file ~out_err:_ ?throw:_ ?canonize:_ s ->
        Format.fprintf out_file
          "\t\t(let v1 = let open R1 in (fun () -> %s) and v2 = let open R2 in \
           (fun () -> %s) in ae \"%s\" v1 v2);\n"
          s s (String.escaped s))
      (fun out_file _ ->
        Format.fprintf out_file
          "\t\tif !nb_fail>0 then exit 1\n\
           end;;\n\
           #mod_use \"%s\"\n\
           #mod_use \"%s\"\n\
           module TA = TestFunctorDiff (%s) (%s) ;;"
          r1 r2 (mname_of_string r1) (mname_of_string r2))
      ~out_err ?throw ?canonize ?tsrange ?boltz_evaluated file_name max n t
      (r1, r2)

  let gen_test_t ?out_err max n t =
    let file = open_out "t.ml" in
    let outf = Format.formatter_of_out_channel file in
    gen_test ?out_err outf max n t;
    Format.pp_print_flush outf ();
    close_out file

  let gen_test_d ?throw ?canonize max n t =
    let file = open_out "t.ml" in
    let outf = Format.formatter_of_out_channel file in
    gen_test_diff ~out_err:true ?throw ?canonize Sys.argv.(1) Sys.argv.(2) outf
      max n t;
    Format.pp_print_flush outf ();
    close_out file

  let gen ?(out_err = true) max n t = gen_test_t ~out_err max n t

  let gen_dir max n t =
    let file = open_out "t.ml" in
    let outf = Format.formatter_of_out_channel file in
    gen_test_direct ~out_err:true outf max n t;
    Format.pp_print_flush outf ();
    close_out file
end

module Gen_for_caseine = struct
  (*let escape_str s =
    if s.[0] = '"' && s.[String.length s - 1] = '"' then
      "\\\"" ^ String.sub s 1 (String.length s - 2) ^ "\\\""
    else s*)

  let copy_file fo s =
    let fi = open_in s in
    try
      while true do
        let l = input_line fi in
        Format.fprintf fo "%s@." l
      done
    with End_of_file -> ()

  let fun_name = ([| "f"; "g"; "h"; "f1"; "f2" |], ref 0)
  let real_name = ([| "x"; "y"; "r" |], ref 0)
  let list_name = ([| "l"; "l1"; "l2" |], ref 0)
  let int_name = ([| "n"; "i"; "j"; "k" |], ref 0)
  let string_name = ([| "s"; "s1"; "s2" |], ref 0)
  let other = ([| "a"; "b"; "c"; "d" |], ref 0)

  let reset () =
    let a (_, r) = r := 0 in
    a fun_name;
    a real_name;
    a list_name;
    a int_name;
    a string_name;
    a other

  let available (t, c) = Array.length t > !c

  let get_name (t, c) =
    incr c;
    t.(!c - 1)

  let get_var t =
    match t with
    | Type.Fun _ when available fun_name -> get_name fun_name
    | Type.Abstract _ when available other -> get_name other
    | Type.Name ("list", _) when available list_name -> get_name list_name
    | Type.Name ("string", _)
    | Type.Name ("simple_string", _)
    | Type.Name ("id_string", _)
      when available string_name ->
        get_name string_name
    | (Type.Name ("int", _) | Type.Name ("nat", _) | Type.Name ("natp", _))
      when available int_name ->
        get_name int_name
    | Type.Name ("float", _) when available real_name -> get_name real_name
    | _ when available other -> get_name other
    | _ ->
        let _, c = other in
        incr c;
        "var_" ^ string_of_int (!c - 1)

  let rec print_var = function
    | [] -> ""
    | [ t ] -> get_var t
    | t :: q -> get_var t ^ " " ^ print_var q

  let gen_random_fun random_fun =
    Format.fprintf Format.str_formatter "%a" random_fun ();
    Format.flush_str_formatter ()

  let gen_consigne ?(is_rec = false) ft =
    reset ();
    Format.fprintf Format.str_formatter
      (*"Écrire la fonction %s\\(\\verb|%a|\\) telle que \\(\\verb|%s %s|\\) "*)
      "&Eacute;crire la fonction %s<code>%a</code> telle que <code>%s \
       %s</code> "
      (if is_rec then "récursive " else "")
      (fun f -> Type.pp_func ~pval:false f)
      ft ft.name (print_var ft.intypes);
    Format.flush_str_formatter ()

  let ct = ref ""
  let name_fun = ref "f"
  let consigne = ref ""
  let base = ref ""

  let gen_base sigs random_fun ts =
    Format.(pp_set_margin str_formatter max_int);
    Format.fprintf Format.str_formatter
      "%a\n\
       module R:EXPSIG = struct\n\
       {{ANSWER}}\n\
       end\n\
       %sopen R\n\
       let to_string_%s = %s\n\
       %s;;\n"
      sigs ()
      (if random_fun = "" then ""
       else
         "open Boltzgen.Runtime\n\
          let _ = \n\
         \  send_warning := true;\n\
         \  set_max_size "
         ^ string_of_int !Runtime.max_size
         ^ ";;\n")
      !name_fun (String.escaped ts)
      (String.escaped random_fun);
    Format.flush_str_formatter ()

  let get_consigne () = !consigne
  let get_base () = !base

  let gen_consigne_base out_file () =
    Format.fprintf out_file
      "--- Consigne -----------\n\
       %s\n\
       --- Base -----------\n\
       %s\n\
       --- vpl_evaluate.cases -------\n"
      !consigne !base

  let gen_header ?(print_base = true) size out_file ~out_err x func sigs ts
      random_fun_def =
    ct := ts;
    name_fun := func.Type.name;
    let rf = gen_random_fun random_fun_def in

    consigne := gen_consigne func;
    base := gen_base sigs rf ts;
    Generator_loop.gen_header size out_file ~out_err x func sigs ts (fun f () ->
        Format.pp_print_string f rf);
    if print_base then
      Format.fprintf out_file "print_endline \"%a\";\n" gen_consigne_base ()
  (*Format.fprintf out_file
      "open Boltzgen.Runtime\n\
       %a\n\
       module TestFunctor (R : EXPSIG ) = struct\n\
       \topen R\n\
       \tlet to_string = %s\n\
       %s"
      sigs () ts rf;
    if print_base then gen_consigne_base out_file ()*)

  let count = ref 1

  let gen_case out_file ~out_err:_ ?throw:_ ?canonize:_ s =
    Format.fprintf out_file "\t\tprint_endline \"Case = Boltzgen test %i\";@."
      !count;
    incr count;
    Format.fprintf out_file "\t\tprint_endline \"input = to_string_%s (%s)\";@."
      !name_fun (String.escaped s);
    (*let esc = if !ct = "(fun s ->\"\\\"\"^s^\"\\\"\")" then "\\\\" else "" in*)
    Format.fprintf out_file
      "\t\tprint_endline (\"output = \"^( (try to_string (%s) with x -> \
       Printexc.to_string x))^\"\");\n\
       print_newline ();@."
      s

  let gen_test2 ?(ftotest = "rendu.ml") ?tsrange ?boltz_evaluated file_name size
      n t =
    Generator_loop.generic_loop
      (fun out_file ~out_err a b sigs ts random_fun_def ->
        Generator_loop.gen_header size out_file ~out_err a b sigs ts
          random_fun_def;
        let rf = gen_random_fun random_fun_def in
        base := gen_base sigs rf ts;
        Format.fprintf out_file
          "\t\tlet print_endline x = print_string (x^\"\\\\n\") in@.\n\
           \t\tlet print_newline () = print_string (\"\\\\n\") in@.")
      gen_case
      (fun out_file _ ->
        Format.fprintf out_file
          "\t\t()\nend;;\n#mod_use \"%s\"\nmodule TA = TestFunctor (%s);;"
          ftotest
          (Generator_loop.mname_of_string ftotest))
      ?tsrange ?boltz_evaluated file_name size n t ftotest

  let gen_test ?(ftotest = "rendu.ml") ?tsrange ?boltz_evaluated file_name size
      n t =
    Generator_loop.generic_loop
      (fun o ->
        Format.fprintf o "open Boltzgen.Runtime\nlet _ = set_max_size %i;;\n"
          (int_of_float size);
        gen_header size o)
      gen_case
      (fun out_file _ ->
        Format.fprintf out_file
          "\t\t()\nend;;\n#mod_use \"%s\"\nmodule TA = TestFunctor (%s);;"
          ftotest
          (Generator_loop.mname_of_string ftotest))
      ?tsrange ?boltz_evaluated file_name size n t ftotest

  let gen_xml ?(vplid = "42095") out fcorrection f =
    let buff = Buffer.create 1024 in
    Format.fprintf (Format.formatter_of_buffer buff) "%a@?" f ();

    Format.fprintf out
      "<?xml version=\"1.0\"  encoding=\"UTF-8\"?>\n\
       <quiz>\n\
      \  <question type=\"vplquestion\">@.\n\
      \    <name>\n\
      \        <text>%s</text>\n\
      \    </name>\n\
      \    <questiontext format=\"html\">\n\
      \        <text><![CDATA[%s]]></text>\n\
      \    </questiontext>\n\
      \    <generalfeedback format=\"html\">\n\
      \      <text></text>\n\
      \    </generalfeedback>\n\
      \    <defaultgrade>1</defaultgrade>\n\
      \    <penalty>0</penalty>\n\
      \    <hidden>0</hidden>\n\
      \    <idnumber></idnumber>\n\
      \    <templatevpl>%s</templatevpl>\n\
      \    <templatelang>ocaml</templatelang>\n\
      \    <templatecontext><![CDATA[%s]]></templatecontext>\n\
      \    <answertemplate></answertemplate>\n\
      \    <teachercorrection><![CDATA[%a]]></teachercorrection>\n\
      \    <validateonsave>1</validateonsave>\n\
      \    <execfiles><![CDATA[{\"vpl_evaluate.cases\":\"@?%s\"}]]></execfiles>\n\
      \     <precheckpreference>same</precheckpreference>\n\
      \     <gradingmethod>0</gradingmethod>\n\
       </question></quiz>@."
      !name_fun !consigne vplid (Scanf.unescaped !base) fcorrection ()
      (String.escaped @@ Buffer.contents buff)
end