Re: [Caml-list] Reordering continuations (was :Type inference inside exceptions ?)

[Diego Olivier FERNANDEZ PONS <diego.fernandez_pons@etu.upmc.fr>]

     Bonjour,

Here is some code that shows the effect of reordering continuations in  
a combinatorial problem. The first one is the minimum cardinality  
subset-sum problem, the second returns the order in which the leaves  
of the search tree are visited.

Each time a solution is found, the number of failures is printed. This  
gives an idea of how much time was spent to find the solution.

(* subsetsum in depth first search *)
# let p = smc 47 [39;32;20;19;16;9;1] in solve p (new stack);;
0 fails : 39 1 1 1 1 1 1 1 1
8 fails : 32 9 1 1 1 1 1 1
47 fails : 20 16 9 1 1
61 fails : 20 9 9 9
118 fails : 19 19 9
- : int list list * int =
([[39; 1; 1; 1; 1; 1; 1; 1; 1]; [32; 9; 1; 1; 1; 1; 1; 1]; [20; 16; 9; 1; 1];
   [20; 9; 9; 9]; [19; 19; 9]],
  457)

(* subset sum in limited discrepancy search *)
# let p = smc 47 [39;32;20;19;16;9;1] in solve p (new queue);;
0 fails : 39 1 1 1 1 1 1 1 1
0 fails : 32 9 1 1 1 1 1 1
16 fails : 19 19 9
- : int list list * int =
([[39; 1; 1; 1; 1; 1; 1; 1; 1]; [32; 9; 1; 1; 1; 1; 1; 1]; [19; 19; 9]], 459

The second example builds a tree which leaves are labelled from 0 to  
2^n - 1 from left to right. The order in which the leaves are visited  
is returned.

# let p = label 4 in solve p (new stack);;
- : int list * int =
([0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15], 0)

# let p = label 4 in solve p (new queue);;
- : int list * int =
([0; 8; 4; 2; 1; 12; 10; 9; 6; 5; 3; 14; 13; 11; 7; 15], 0)

Here is the complete code

class type ['a] continuationQueue =
   object
     method push : 'a -> unit
     method pop : 'a
     method is_empty : bool
     method length : int
   end

class ['a] queue =
   (object
     val contents = (Queue.create () : 'a Queue.t)
     method push = fun x -> Queue.push x contents
     method pop = Queue.pop contents
     method is_empty = Queue.is_empty contents
     method length = Queue.length contents
   end : ['a] continuationQueue)

class ['a] stack =
   (object
     val contents = (Stack.create () : 'a Stack.t)
     method push = fun x -> Stack.push x contents
     method pop = Stack.pop contents
     method is_empty = Stack.is_empty contents
     method length = Stack.length contents
   end : ['a] continuationQueue)

type 'a environment = {
     mutable backtracks : int;
     mutable objective : int;
     mutable queue : 'a queue
  }

exception Fail

type 'a continuation = Cont of (unit -> 'a)

let rec print_list = function
   | [] -> print_newline()
   | x :: tail -> print_int x; print_string " "; print_list tail

let rec min_card env = fun to_reach chosen candidates ->
   if (to_reach = 0) then
     match compare env.objective (List.length chosen) with
     | n when n <= 0 ->
	env.backtracks <- env.backtracks + 1;
	raise Fail
     | _ ->
	env.objective <- List.length chosen;
	print_int env.backtracks;
	print_string " fails : ";
	print_list (List.rev chosen);
	(List.rev chosen)
   else
     match candidates with
     | [] ->
	env.backtracks <- env.backtracks + 1;
	raise Fail
     | x :: tail when x > to_reach -> min_card env to_reach chosen tail
     | x :: tail ->
	let c = Cont (fun () -> min_card env to_reach chosen tail) in
	env.queue#push c;
	min_card env (to_reach - x) (x :: chosen) candidates

let smc = fun to_reach list ->
   function env ->
     let c = Cont (function () -> min_card env to_reach [] list) in
     env.queue#push c; env

let rec label_nodes env = fun count remaining_depth ->
   match remaining_depth with
     | 0 -> count
     | n ->
	let c = Cont (fun () -> label_nodes env (2 * count + 1) (n - 1)) in
	  env.queue#push c;
	  label_nodes env (2 * count) (n - 1)

let label = function depth ->
   function env ->
     let c = Cont (fun () -> label_nodes env 0 depth) in
       env.queue#push c; env

let rec solve_rec = function env ->
   if env.queue#is_empty then []
   else
     let Cont c = env.queue#pop in
     try
       let s = c () in
       s :: solve_rec env
     with Fail -> solve_rec env

let solve = fun f queue ->
   let env = { backtracks = 0; objective = max_int; queue = queue } in
   let solutions = solve_rec (f env) in
   (solutions, env.backtracks)

         Diego Olivier