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

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

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 ]

let problem_generate () =
  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
      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;
  }

type operations =
  | OpAdd of int * int
  | OpSub of int * int
  | OpMul of int * int
  | OpDiv of int * int

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

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

let problem_solution sol =
  List.iter (fun o -> match o with
	       | OpAdd (m, n) -> Printf.printf "%d + %d = %d\n" m n (m + n)
	       | OpSub (m, n) -> Printf.printf "%d - %d = %d\n" m n (m - n)
	       | OpMul (m, n) -> Printf.printf "%d * %d = %d\n" m n (m * n)
	       | OpDiv (m, n) -> Printf.printf "%d / %d = %d\n" m n (m / n)) (List.rev sol);
  print_newline ()

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

let add_solution sol sols =

(* FIXME: to be improved *)
  let solution_eq s1 s2 =
    let opcompare op1 op2 =
      match op1, op2 with
	| OpAdd (m1, n1), OpAdd (m2, n2) ->
	    if m1 = m2 && n1 = n2 || m1 = n2 && n1 = m2 then 0
	    else 
	      let c1 = compare m1 m2 in
	      if c1 != 0 then c1 else compare n1 n2
	| OpAdd _, _ -> -1
	| OpSub _, OpAdd _ -> 1
	| OpSub (m1, n1), OpSub (m2, n2) ->
	    let c1 = compare m1 m2 in
	    if c1 != 0 then c1 else compare n1 n2
	| OpSub _, _ -> -1
	| OpMul _, OpAdd _ | OpMul _, OpSub _ -> 1
	| OpMul (m1, n1), OpMul (m2, n2) ->
	    if m1 = m2 && n1 = n2 || m1 = n2 && n1 = m2 then 0
	    else 
	      let c1 = compare m1 m2 in
	      if c1 != 0 then c1 else compare n1 n2
	| OpMul _, _ -> -1
	| OpDiv (m1, n1), OpDiv (m2, n2) ->
	    let c1 = compare m1 m2 in
	    if c1 != 0 then c1 else compare n1 n2
	| OpDiv _, _ -> 1 in

    List.sort opcompare s1 = List.sort opcompare s2 in

  let rec solutions_mem sol sols =
    match sols with
      | [] -> false
      | h :: q ->
	  solution_eq sol h || solutions_mem sol q in

  if List.mem sol sols.solutions_list then 
    sols 
  else if solutions_mem sol sols.solutions_list then
    sols
  else
    let newl = List.length sol in
    if newl > sols.solutions_shortest then
      sols
    else
      {
	solutions_shortest = if newl < sols.solutions_shortest then newl else sols.solutions_shortest;
	solutions_list = sol :: List.filter (fun s -> List.length s <= newl) sols.solutions_list }

let rec problem_solve p sol 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 > 0 && n > 0 then
	  problem_solve { p with problem_numbers = m + n :: pn } (OpAdd (m, n) :: sol) sols (fun sols ->
          (if m >= n then
            problem_solve { p with problem_numbers = m - n :: pn } (OpSub (m, n) :: sol)
          else
            problem_solve { p with problem_numbers = n - m :: pn } (OpSub (n, m) :: sol)) sols (fun sols ->
	  if m >= 2 && n >= 2 then
            problem_solve { p with problem_numbers = m * n :: pn } (OpMul (m, n) :: sol) sols (fun sols ->
	    if m >= n then
	      if m mod n = 0 then
                problem_solve { p with problem_numbers = m / n :: pn } (OpDiv (m, n) :: sol) sols cont
	      else cont sols
	    else if n mod m = 0 then
              problem_solve { p with problem_numbers = n / m :: pn } (OpDiv (n, m) :: sol) sols cont
	    else cont sols)
	  else
	    cont sols))
	else
	  cont sols
      in
      match l with
	| [] -> cont sols
	| h :: q ->
	    solve_aux3 m h (list_rem 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_rem h p.problem_numbers) sols (fun sols ->
	    solve_aux1 q sols cont) in

  if List.mem p.problem_target p.problem_numbers then
    cont (add_solution sol sols)
(* if about to find suboptimal solutions, give up *)
  else if List.length sol >= 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 = 443; problem_numbers = [75; 7; 4; 50; 4; 5] } in *)
  problem_print p;
  problem_solve p []
    { solutions_shortest = max_int;
      solutions_list = [] }
    (fun sols -> 
      Printf.printf "%d solutions found, shortest(s) have %d steps.\n" (List.length sols.solutions_list) sols.solutions_shortest;
      List.iter problem_solution sols.solutions_list;
      Printf.printf "Done.\n")