在 OCaml 中创造一个世纪

Question

这是一个相当典型的make a century 问题。

我们有一个自然数列表[1;2;3;4;5;6;7;8;9]。

我们有一个可能的运营商列表[Some '+'; Some '*';None]。

现在我们根据上述可能性创建一个运算符列表，并将每个运算符插入到数字列表中的每个连续数字之间并计算值。

（注意a None b = a * 10 + b）

例如，如果运算符列表为[Some '+'; Some '*'; None; Some '+'; Some '+'; Some '+'; Some '+'; Some '+']，则值为1 + 2 * 34 + 5 + 6 + 7 + 8 + 9 = 104。

请找到所有可能的运算符列表，所以the value = 10。

---

我能想到的唯一方法是蛮力。

我生成所有可能的运算符列表。

计算所有可能的值。

然后过滤，我得到所有产生 100 的运算符列表。

exception Cannot_compute

let rec candidates n ops =
  if n = 0 then [[]]
  else 
    List.fold_left (fun acc op -> List.rev_append acc (List.map (fun x -> op::x) (candidates (n-1) ops))) [] ops


let glue l opl =
  let rec aggr acc_l acc_opl = function
    | hd::[], [] -> (List.rev (hd::acc_l), List.rev acc_opl)
    | hd1::hd2::tl, None::optl -> aggr acc_l acc_opl (((hd1*10+hd2)::tl), optl)
    | hd::tl, (Some c)::optl -> aggr (hd::acc_l) ((Some c)::acc_opl) (tl, optl)
    | _ -> raise Cannot_glue
  in 
  aggr [] [] (l, opl)

let compute l opl =
  let new_l, new_opl = glue l opl in
  let rec comp = function
    | hd::[], [] -> hd 
    | hd::tl, (Some '+')::optl -> hd + (comp (tl, optl))
    | hd1::hd2::tl, (Some '-')::optl -> hd1 + (comp ((-hd2)::tl, optl))
    | hd1::hd2::tl, (Some '*')::optl -> comp (((hd1*hd2)::tl), optl)
    | hd1::hd2::tl, (Some '/')::optl -> comp (((hd1/hd2)::tl), optl)
    | _, _ -> raise Cannot_compute
  in 
  comp (new_l, new_opl)

let make_century l ops =
  List.filter (fun x -> fst x = 100) (
    List.fold_left (fun acc x -> ((compute l x), x)::acc) [] (candidates ((List.length l)-1) ops))

let rec print_solution l opl =
  match l, opl with
    | hd::[], [] -> Printf.printf "%d\n" hd 
    | hd::tl, (Some op)::optl -> Printf.printf "%d %c " hd op; print_solution tl optl
    | hd1::hd2::tl, None::optl -> print_solution ((hd1*10+hd2)::tl) optl
    | _, _ -> ()

---

我相信我的代码很难看。所以我有以下问题

1. computer l opl 是使用数字列表和运算符列表进行计算。基本上这是一个典型的数学评估。有没有更好的实现方式？
2. 我已阅读Pearls of Functional Algorithm Design 中的第 6 章。它使用了一些技术来提高性能。我发现它真的很晦涩难懂。 任何读过它的人都可以帮忙吗？

编辑

我改进了我的代码。基本上，我将首先扫描操作员列表，以将其操作员为None 的所有数字粘合起来。

然后在计算中，如果我遇到'-'，我将简单地否定第二个数字。

Answer 1

一个经典的动态规划解决方案（找到= 104 立即解决），不会给操作员带来任何问题 关联性或优先级。它只返回一个布尔值，表示是否 可以带号码；修改它以返回 获得解决方案的操作序列是一个简单但有趣的 锻炼，我没有动力去那么远。

let operators = [ (+); ( * ); ]

module ISet = Set.Make(struct type t = int let compare = compare end)

let iter2 res1 res2 f =
  res1 |> ISet.iter @@ fun n1 ->
  res2 |> ISet.iter @@ fun n2 ->
  f n1 n2

let can_make input target =
  let has_zero = Array.fold_left (fun acc n -> acc || (n=0)) false input in
  let results = Array.make_matrix (Array.length input) (Array.length input) ISet.empty in
  for imax = 0 to Array.length input - 1 do
    for imin = imax downto 0 do
      let add n =
        (* OPTIMIZATION: if the operators are known to be monotonous, we need not store
           numbers above the target;

           (Handling multiplication by 0 requires to be a bit more
           careful, and I'm not in the mood to think hard about this
           (I think one need to store the existence of a solution,
           even if it is above the target), so I'll just disable the
           optimization in that case)
        *)
        if n <= target && not has_zero then
          results.(imin).(imax) <- ISet.add n results.(imin).(imax) in
      let concat_numbers =
        (* concatenates all number from i to j:
           i=0, j=2 -> (input.(0)*10 + input.(1))*10 + input.(2)
        *)
        let rec concat acc k =
          let acc = acc + input.(k) in
          if k = imax then acc
          else concat (10 * acc) (k + 1)
        in concat 0 imin
      in add concat_numbers;
      for k = imin to imax - 1 do
        let res1 = results.(imin).(k) in
        let res2 = results.(k+1).(imax) in
        operators |> List.iter (fun op ->
          iter2 res1 res2 (fun n1 n2 -> add (op n1 n2););
        );
      done;
    done;
  done;
  let result = results.(0).(Array.length input - 1) in
  ISet.mem target result

Answer 2

这是我的解决方案，它根据通常的优先规则进行评估。它在我的 MacBook Pro 上不到 1/10 秒就找到了 find [1;2;3;4;5;6;7;8;9] 100 的 303 个解决方案。

这里有两个有趣的：

# 123 - 45 - 67 + 89;;
- : int = 100
# 1 * 2 * 3 - 4 * 5 + 6 * 7 + 8 * 9;;
- : int = 100

这是一个蛮力解决方案。唯一有点聪明的地方是，我将数字的串联视为另一种（高优先级）操作。

eval 函数是标准的基于堆栈的中缀表达式求值，您会在很多地方找到它的描述。这是一篇关于它的 SO 文章：How to evaluate an infix expression in just one scan using stacks? 本质是通过将运算符和操作数压入堆栈来推迟评估。当您发现下一个运算符的优先级较低时，您可以返回并评估您推送的内容。

type op = Plus | Minus | Times | Divide | Concat

let prec = function
    | Plus | Minus -> 0
    | Times | Divide -> 1
    | Concat -> 2

let succ = function
    | Plus -> Minus
    | Minus -> Times
    | Times -> Divide
    | Divide -> Concat
    | Concat -> Plus

let apply op stack =
    match op, stack with
    | _, [] | _, [_] -> [] (* Invalid input *)
    | Plus, a :: b :: tl -> (b + a) :: tl
    | Minus, a :: b :: tl -> (b - a) :: tl
    | Times, a :: b :: tl -> (b * a) :: tl
    | Divide, a :: b :: tl -> (b / a) :: tl
    | Concat, a :: b :: tl -> (b * 10 + a) :: tl

let rec eval opstack numstack ops nums =
    match opstack, numstack, ops, nums with
    | [], sn :: _, [], _ -> sn
    | sop :: soptl, _, [], _ ->
        eval soptl (apply sop numstack) ops nums
    | [], _, op :: optl, n :: ntl ->
        eval [op] (n :: numstack) optl ntl
    | sop :: soptl, _, op :: _, _ when prec sop >= prec op ->
        eval soptl (apply sop numstack) ops nums
    | _, _, op :: optl, n :: ntl ->
        eval (op :: opstack) (n :: numstack) optl ntl
    | _ -> 0 (* Invalid input *)

let rec incr = function
    | [] -> []
    | Concat :: rest -> Plus :: incr rest
    | x :: rest -> succ x :: rest

let find nums tot =
    match nums with
    | [] -> []
    | numhd :: numtl ->
        let rec try1 ops accum =
            let accum' =
                if eval [] [numhd] ops numtl = tot then
                    ops :: accum
                else
                    accum
            in
            if List.for_all ((=) Concat) ops then
                accum'
            else try1 (incr ops) accum'
        in
        try1 (List.map (fun _ -> Plus) numtl) []

Answer 3

我想出了一个略显晦涩的实现（对于这个问题的变体），它比蛮力要好一点。它在原地工作，而不是生成中间数据结构，跟踪已评估的运算符的组合值。

诀窍是跟踪待处理的运算符和值，以便您可以轻松评估“无”运算符。也就是说，如果算法刚刚通过1 + 23，则待处理运算符将为+，待处理值将为23，允许您根据需要轻松生成1 + 23 + 4 或1 + 234。

type op = Add | Sub | Nothing

let print_ops ops =
  let len = Array.length ops in
  print_char '1';
  for i = 1 to len - 1 do
    Printf.printf "%s%d" (match ops.(i) with
     | Add -> " + "
     | Sub -> " - "
     | Nothing -> "") (i + 1)
  done;
  print_newline ()

let solve k target =
  let ops = Array.create k Nothing in
  let rec recur i sum pending_op pending_value =
    let sum' = match pending_op with
      | Add -> sum + pending_value
      | Sub -> if sum = 0 then pending_value else sum - pending_value
      | Nothing -> pending_value in
    if i = k then
      if sum' = target then print_ops ops else ()
    else
      let digit = i + 1 in
      ops.(i) <- Add;
      recur (i + 1) sum' Add digit;
      ops.(i) <- Sub;
      recur (i + 1) sum' Sub digit;
      ops.(i) <- Nothing;
      recur (i + 1) sum pending_op (pending_value * 10 + digit) in
  recur 0 0 Nothing 0

请注意，这会产生重复 - 我没有费心去解决这个问题。此外，如果您通过此练习来增强函数式编程的能力，那么拒绝此处采用的命令式方法并寻找不使用赋值的类似解决方案可能会有所帮助。