Cheap numbers in Piet (Ocaml)

(* Made for https://math.stackexchange.com/questions/2355111/making-numbers-cheaply *)
(* Inspired by https://pastebin.com/9kiLL3x5 *)
(* Compile using `ocamlbuild -use-ocamlfind -package batteries climb.native` *)

open Batteries

module MakeCheap = struct
  module H = BatHashtbl
  module V = BatVect

  type seq = int list
  let int_max = BatInt.max_num
  type binary_op = PAdd | PSub | PMul | PDiv | PMod
  type elem = Number of int | PDup | Binary of binary_op
  type path = elem list

  let string_of_elem = function
    | Number x -> string_of_int x
    | PDup -> "@"
    | Binary PAdd -> "+"
    | Binary PSub -> "-"
    | Binary PMul -> "*"
    | Binary PDiv -> "/"
    | Binary PMod -> "%"

  type full_history = {
    maxc : int ref;
    best : (int, int * elem list) H.t; (* number -> (cost, path) *)
    hist : (seq, int) H.t;             (* sequence -> length of best path *)
    lim  : int;
    def  : elem list;
  }

  type path_history = {
    cost : int;
    path : path;
    st_l : seq list;
  }

  let rec branch path_h full_h =
    if path_h.cost >= !(full_h.maxc) then full_h else
      let make_kids acc = function
        | PDup -> (match path_h.st_l with
            | (h :: t) :: _ -> (PDup, path_h.cost + 1, h :: h :: t) :: acc
            | _ -> acc)
        | Binary x
          -> (match path_h.st_l with
              | (a :: b :: t) :: _ ->
                if (b < 0 && x = PMod) ||
                   (a = 0 && (x = PDiv || x = PMod)) then acc
                else let ab_op = (match x with
                    | PAdd -> b + a
                    | PSub -> b - a
                    | PMul -> b * a
                    | PDiv -> b / a
                    | PMod -> b mod a) in
                  (Binary x, path_h.cost + 1, ab_op :: t) :: acc
              | _ -> acc)
        | Number x -> (Number x, path_h.cost + x,
                       (match path_h.st_l with
                        | [] -> [x]
                        | h :: _ -> x :: h)) :: acc in
      let traverse path_h fh (el, cost, seq) =
        if cost > !(fh.maxc) then fh
        else
          let old_c = match H.find_option fh.hist seq with
            | Some x -> x
            | None -> int_max in
          if cost >= old_c then fh
          else
            let _ =
              H.replace fh.hist seq cost;
              if List.length seq = 1 then
                let x = List.hd seq in
                if x < 0 then () else
                  let old_c = match H.find_option fh.best x with
                    | Some (y, _) -> y
                    | None -> int_max in
                  if cost < old_c then begin
                    H.replace fh.best x (cost, el :: path_h.path);
                    if old_c = !(fh.maxc) then
                      fh.maxc :=
                        List.range 1 `To fh.lim
                        |> List.map (fst % H.find fh.best)
                        |> List.reduce BatInt.max
                  end
            in
            branch {cost = cost; path = el :: path_h.path;
                    st_l = seq :: path_h.st_l} fh
      in
      full_h.def
      |> List.fold_left make_kids []
      |> List.fold_left (traverse path_h) full_h

  let find_all_cheaply max_num goal =
    let start_path_h = {cost = 0; path = []; st_l = [];} in
    let start_full_h guess = {
      best = (List.range 1 `To goal)
             |> List.map (fun x -> (x, (guess, [])))
             |> H.of_list;
      maxc = ref guess;
      hist = H.create 1024;
      def = [PDup;]
            |> List.append
               % List.map (fun x -> Binary x) @@ [PAdd; PSub; PMul; PDiv; PMod;]
            |> List.append
               % List.map (fun x -> Number x) @@ (List.range 1 `To max_num);
      lim = goal;
    } in

    let rec run_branch guess full_h =
      let fh = branch start_path_h full_h in
      if List.range 1 `To goal
         |> List.map ((=) guess % fst % H.find fh.best)
         |> List.reduce (||) then
        run_branch (guess + 1) (start_full_h (guess + 1))
      else fh
    in

    let full_h = run_branch 16 (start_full_h 16) in
    List.range 1 `To goal
    |> List.map (fun a -> (a, H.find full_h.best a))
    |> List.map (fun (a, (l,s)) -> (a,l, List.map (string_of_elem) @@ List.rev s))
    |> List.sort (fun (a1,_,_) (a2,_,_) -> compare a1 a2)
    |> List.map
      (fun (a,l,s) -> let _ = print_endline @@ Printf.sprintf "%3d (%2d) %s" a l
                        @@ List.fold_left (^) "" s in (a,l,s))

end

let _ = MakeCheap.find_all_cheaply 5 256