This site is updated infrequently. For up-to-date information, please visit the new OCaml website at ocaml.org.

Type inference inside exceptions ?
[ Home ] [ Index: by date | by threads ]
[ Search: ]

[ Message by date: previous | next ] [ Message in thread: previous | next ] [ Thread: previous | next ]
 Date: -- (:) From: Diego Olivier FERNANDEZ PONS Subject: Re: [Caml-list] Reordering continuations (was :Type inference inside exceptions ?)
```     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

```