Make a century in OCaml

Question

Here is quite a typical make a century problem.

We have a natural number list [1;2;3;4;5;6;7;8;9].

We have a list of possible operators [Some '+'; Some '*';None].

Now we create a list of operators from above possibilities and insert each operator into between each consecutive numbers in the number list and compute the value.

(Note a None b = a * 10 + b)

For example, if the operator list is [Some '+'; Some '*'; None; Some '+'; Some '+'; Some '+'; Some '+'; Some '+'], then the value is 1 + 2 * 34 + 5 + 6 + 7 + 8 + 9 = 104.

Please find all possible operator lists, so the value = 10.

---

The only way I can think of is brute-force.

I generate all possible operator lists.

Compute all possible values.

Then filter so I get all operator lists which produce 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
    | _, _ -> ()

---

I believe my code is ugly. So I have the following questions

1. computer l opl is to compute using the number list and operator list. Basically it is a typical math evaluation. Is there any nicer implementation?
2. I have read Chapter 6 in Pearls of Functional Algorithm Design. It used some techniques to improve the performance. I found it really really obscurity and hard to understand. Anyone who read it can help?

Edit

I refined my code. Basically, I will scan the operator list first to glue all numbers where their operator is None.

Then in compute, if I meet a '-' I will simply negate the 2nd number.

Answer 1

A classic dynamic programming solution (which finds the = 104 solution instantly) that does not risk any problem with operators associativity or precedence. It only returns a boolean saying whether it's possible to come with the number; modifying it to return the sequences of operations to get the solution is an easy but interesting exercise, I was not motivated to go that far.

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

Here is my solution, which evaluates according to the usual rules of precedence. It finds 303 solutions to find [1;2;3;4;5;6;7;8;9] 100 in under 1/10 second on my MacBook Pro.

Here are two interesting ones:

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

This is a brute force solution. The only slightly clever thing is that I treat concatenation of digits as simply another (high precedence) operation.

The eval function is the standard stack-based infix expression evaluation that you will find described many places. Here is an SO article about it: How to evaluate an infix expression in just one scan using stacks? The essence is to postpone evaulating by pushing operators and operands onto stacks. When you find that the next operator has lower precedence you can go back and evaluate what you pushed.

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

I came up with a slightly obscure implementation (for a variant of this problem) that is a bit better than brute force. It works in place, rather than generating intermediate data structures, keeping track of the combined values of the operators that have already been evaluated.

The trick is to keep track of a pending operator and value so that you can evaluate the "none" operator easily. That is, if the algorithm had just progressed though 1 + 23, the pending operator would be +, and the pending value would be 23, allowing you to easily generate either 1 + 23 + 4 or 1 + 234 as necessary.

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

Note that this will generate duplicates - I didn't bother to fix that. Also, if you are doing this exercise to gain strength in functional programming, it might be beneficial to reject the imperative approach taken here and search for a similar solution that doesn't make use of assignments.