(* Lettres (du jeu "des chiffres et des lettres") *)

type fourop =
  | Const
  | OpAdd of operation * operation
  | OpSub of operation * operation
  | OpMul of operation * operation
  | OpDiv of operation * operation
and
operation =
{
  operation_op : fourop;
  operation_value : int;
  operation_steps : int;
}

let operation_of_int i =
  {
    operation_op = Const;
    operation_value = i;
    operation_steps = 0
  }

let operation_of_fourop fop =
  match fop with
    | Const -> failwith "a constant is not an operation"
    | OpAdd (m, n) -> {
	operation_op = fop;
	operation_value = m.operation_value + n.operation_value;
	operation_steps = 1 + m.operation_steps + n.operation_steps }
    | OpSub (m, n) -> {
	operation_op = fop;
	operation_value = m.operation_value - n.operation_value;
	operation_steps = 1 + m.operation_steps + n.operation_steps }
    | OpMul (m, n) -> {
	operation_op = fop;
	operation_value = m.operation_value * n.operation_value;
	operation_steps = 1 + m.operation_steps + n.operation_steps }
    | OpDiv (m, n) -> {
	operation_op = fop;
	operation_value = m.operation_value / n.operation_value;
	operation_steps = 1 + m.operation_steps + n.operation_steps }

type problem = 
{ 
  problem_target : int;
  problem_numbers : operation list;
}

let problem_generate () =
  let boards =
    [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10;
      1; 2; 3; 4; 5; 6; 7; 8; 9; 10;
      25; 50; 75; 100 ] in
  let rec random_boards_list n boards_left =
    let rec remove_nth n l =
      match l with
	| [] -> l
	| h :: q -> if n = 0 then q else h :: remove_nth (n-1) q
    in
    if n = 0 then []
    else
      let choice = Random.int (List.length boards_left) in
      operation_of_int (List.nth boards_left choice) :: 
      random_boards_list (n-1) (remove_nth choice boards_left) 
  in
  { 
    problem_target = 100 + Random.int 900;
    problem_numbers = random_boards_list 6 boards;
  }

let problem_print p =
  Printf.printf "How to get %d out of:\n" p.problem_target;
  List.iter (fun n -> assert (n.operation_op = Const);
	       Printf.printf "%d " n.operation_value) p.problem_numbers;
  print_newline ()

let rec list_remq e l =
  match l with
    | [] -> l
    | h :: q when h = e -> q
    | h :: q -> h :: list_remq e q

let solution_print sol =
  let rec sol_aux sol parens =
    match sol.operation_op with
      | Const -> Printf.printf "%d" sol.operation_value
      | OpAdd (m, n) -> if parens then Printf.printf "(";
                        sol_aux m false;
	                Printf.printf " + ";
	                sol_aux n false;
			if parens then Printf.printf ")";
      | OpSub (m, n) -> if parens then Printf.printf "(";
                        sol_aux m false;
	                Printf.printf " - ";
	                sol_aux n (match n.operation_op with
				     | OpAdd _ | OpSub _ -> true
				     | _ -> false);
			if parens then Printf.printf ")";
      | OpMul (m, n) -> if parens then Printf.printf "(";
                        sol_aux m (match m.operation_op with
				     | OpMul _ -> false
				     | _ -> true);
	                Printf.printf " * ";
	                sol_aux n (match n.operation_op with
				     | OpMul _ | OpDiv _ -> false
				     | _ -> true);
			if parens then Printf.printf ")";
      | OpDiv (m, n) -> if parens then Printf.printf "(";
                        sol_aux m (match m.operation_op with
				     | OpMul _ | OpDiv _ -> false
				     | _ -> true);
	                Printf.printf " / ";
	                sol_aux n (match n.operation_op with
				     | OpDiv _ -> false
				     | _ -> true);
			if parens then Printf.printf ")"
  in
  sol_aux sol false;
  print_newline ()

type solutions = {
  solutions_shortest : int;
  solutions_list : operation list
}

let add_solution sol sols =

(* FIXME: to be improved *)
  let rec solution_canonize sol =
    match sol.operation_op with
      | Const -> sol
      | OpAdd (m, n) ->
	  let m = solution_canonize m in
	  let n = solution_canonize n in
	  if m.operation_value < n.operation_value then
	    { sol with operation_op = OpAdd (n,m) }
	  else
	    { sol with operation_op = OpAdd (m,n) }
      | OpMul (m, n) ->
	  let m = solution_canonize m in
	  let n = solution_canonize n in
	  if m.operation_value < n.operation_value then
	    { sol with operation_op = OpMul (n,m) }
	  else
	    { sol with operation_op = OpMul (m,n) }
      | OpSub (m, n) ->
	  let m = solution_canonize m in
	  let n = solution_canonize n in
	  { sol with operation_op = OpSub (m,n) }
      | OpDiv (m, n) ->
	  let m = solution_canonize m in
	  let n = solution_canonize n in
	  { sol with operation_op = OpDiv (m,n) }
  in

  let sol = solution_canonize sol in
  if List.mem sol sols.solutions_list then 
    sols 
  else
    let newl = sol.operation_steps in
    if newl > sols.solutions_shortest then
      sols
    else if newl < sols.solutions_shortest then
      { solutions_shortest = newl; solutions_list = [ sol ] }
    else
      {	sols with solutions_list = sol :: sols.solutions_list }

let rec problem_solve p sols cont =

  let rec solve_aux1 l sols cont =
    let rec solve_aux2 m l pn sols cont =
      let solve_aux3 m n pn sols cont =
	if m.operation_value > 0 && n.operation_value > 0 then
	  problem_solve 
	    { p with problem_numbers = operation_of_fourop (OpAdd (m, n)) :: pn }
	    sols (fun sols ->
          (if m.operation_value >= n.operation_value then
            problem_solve 
	      { p with problem_numbers = operation_of_fourop (OpSub (m, n)) :: pn }
          else
            problem_solve 
	      { p with problem_numbers = operation_of_fourop (OpSub (n, m)) :: pn }) sols (fun sols ->
	  if m.operation_value >= 2 && n.operation_value >= 2 then
            problem_solve { p with problem_numbers = operation_of_fourop (OpMul (m, n)) :: pn } sols (fun sols ->
	    if m.operation_value >= n.operation_value then
	      if m.operation_value mod n.operation_value = 0 then
                problem_solve { p with problem_numbers = operation_of_fourop (OpDiv (m, n)) :: pn } sols cont
	      else cont sols
	    else if n.operation_value mod m.operation_value = 0 then
              problem_solve { p with problem_numbers = operation_of_fourop (OpDiv (n, m)) :: pn } sols cont
	    else cont sols)
	  else
	    cont sols))
	else
	  cont sols
      in
      match l with
	| [] -> cont sols
	| h :: q ->
	    solve_aux3 m h (list_remq h pn) sols (fun sols ->
	      solve_aux2 m q pn sols cont) in
    match l with
      |	[] -> cont sols
      | h :: q ->
	  solve_aux2 h q (list_remq h p.problem_numbers) sols (fun sols ->
	    solve_aux1 q sols cont) in

  let o = List.hd p.problem_numbers in
  if o.operation_value = p.problem_target then
    cont (add_solution o sols)
(* if about to find suboptimal solutions, give up *)
  else if o.operation_steps >= sols.solutions_shortest then
    cont sols
  else
    solve_aux1 p.problem_numbers sols cont

let _ =
  Random.self_init ();
  let p = problem_generate () in
(*  let p = { problem_target = 989; 
	    problem_numbers = [operation_of_int 7; operation_of_int 5; 
			       operation_of_int 6; operation_of_int 7; 
			       operation_of_int 1; operation_of_int 25] } in *)
  problem_print p;
  problem_solve p
    { solutions_shortest = max_int;
      solutions_list = [] }
    (fun sols -> 
      Printf.printf "%d solution(s) of %d step(s) found.\n" (List.length sols.solutions_list) sols.solutions_shortest;
      List.iter solution_print sols.solutions_list;
      Printf.printf "Done.\n")