(* Generators in OCaml
As the first attempt, we use the general theory:
yield = exceptions + non-determinism
which we will optimize later. For non-determinism, we use HANSEI. For
exceptions -- native OCaml exceptions.
The general theory applies immediately: It just works.
*)
(* When working at the top-level, do:
#load "prob.cma";;
*)
open ProbM;; (* The HANSEI library *)
open Ptypes;;
(* Define yield, as derived in the general theory *)
let yield x = if flip 0.5 then raise x
;;
(* That is all needed to define generators *)
(* ------------------------------------------------------------------------ *)
(* Examples: in-order and post-order traversals of a tree *)
(* A few preliminaries: define the tree and build a sample one *)
type label = int
type tree = Leaf | Node of label * tree * tree;;
let make_full_tree depth =
let rec loop label = function
| 0 -> Leaf
| n -> Node (label, loop (2*label) (pred n), loop (2*label+1) (pred n))
in loop 1 depth
;;
(* val make_full_tree : int -> tree = *)
let tree1 = make_full_tree 3;;
(*
val tree1 : tree =
Node (1, Node (2, Node (4, Leaf, Leaf), Node (5, Leaf, Leaf)),
Node (3, Node (6, Leaf, Leaf), Node (7, Leaf, Leaf)))
*)
(* Declare the exception to carry the yielded value *)
exception YT of int;;
(* The traversal code itself *)
let rec in_order2 = function
| Leaf -> ()
| Node (label, left, right) ->
in_order2 left;
yield (YT label);
in_order2 right
;;
(* val in_order2 : tree -> unit = *)
(* The first test: print the labels as they are yielded *)
let t1 = exact_reify (fun () ->
try in_order2 tree1
with YT x -> Printf.printf "Got %d\n" x
);;
(* The second test: accumulate the results in a list *)
let t12 = exact_reify (fun () ->
try in_order2 tree1; None
with YT x -> Some x
);;
(*
val t12 : int option Ptypes.pV =
[(0.0078125, V (Some 7)); (0.03125, V (Some 6)); (0.125, V (Some 5));
(0.5, V (Some 4)); (0.015625, V (Some 3)); (0.25, V (Some 2));
(0.0625, V (Some 1)); (0.0078125, V None)]
*)
(* More challenging and interesting is post_order example,
an accumulating traversal yielding intermediate results.
We traverse a tree post-order, yielding the running sum of
the current label and the labels in the left and the right
branches (that is, the sum of the labels for the subtree rooted
at the current node).
Now the generator has to return a useful value.
*)
let rec post_order = function
| Leaf -> 0
| Node (label, left, right) ->
let sum_left = post_order left in
let sum_right = post_order right in
let sum = sum_left + sum_right + label in
yield (YT sum); sum
;;
(* val post_order : tree -> int = *)
let tp1 = exact_reify (fun () ->
try Printf.printf "Final: %d\n" (post_order tree1)
with YT x -> Printf.printf "Got %d\n" x
);;
(*
Got 4
Got 5
Got 11
Got 6
Got 7
Got 16
Got 28
Final: 28
val tp1 : unit Ptypes.pV = [(1., Ptypes.V ())]
*)
(* We do not care about probabilities in this application;
we do care about the order of results.
The inference procedure exact_reify we used so far
does the opposite.
We define a new `inference' procedure, to convert the
probabilistic model, reified into a lazy tree, into
a stream (to flatten the tree).
*)
type 'a stream = Nil of 'a | Cons of 'a * (unit -> 'a stream);;
let rec stream_append s1 s2 =
match s1 with
| Nil x -> Cons (x,s2)
| Cons (x,s1') -> Cons (x,fun () -> stream_append (s1' ()) s2)
;;
(* val stream_append : 'a stream -> (unit -> 'a stream) -> 'a stream =
*)
(* [stream_to_list n s]
converts at most n first element of the stream to list.
[n : int option] is the limit; None means no limit.
*)
let stream_to_list n s =
let predM = function
| Some n -> Some (pred n)
| None -> None in
let is_done = function
| Some n when n <= 0 -> true
| _ -> false in
let rec loop n acc s =
if is_done n then List.rev acc else
match s () with
| Nil x -> List.rev (x::acc)
| Cons (x,s) -> loop (predM n) (x::acc) s
in loop n [] (fun () -> s)
;;
(* val stream_to_list : int option -> 'a stream -> 'a list = *)
(* This function could be written more nicely.
We will derive a more efficient implementation of generators
anyway, see the file generator.ml
The pattern-matching is deliberately inexhaustive;
It covers only the cases that may occur if we use yield
but not other Hansei operations.
*)
let stream_reify model =
let rec loop = function
| [(_,V x)] -> Nil x
| [(_,C t1);(_,C t2)] ->
stream_append (loop (t1 ())) (fun () -> loop (t2 ()))
in loop (reify0 model)
;;
(* val stream_reify : (unit -> 'a) -> 'a stream = *)
(* We repeat the earlier tests, using the new stream reification function *)
(* The second test: accumulate the results in a list *)
let [Some 4; Some 2; Some 5; Some 1; Some 6; Some 3; Some 7; None] =
stream_to_list None (stream_reify (fun () ->
try in_order2 tree1; None
with YT x -> Some x
));;
let _ =
stream_to_list None (stream_reify (fun () ->
try Printf.printf "Final: %d\n" (post_order tree1)
with YT x -> Printf.printf "Got %d\n" x
));;
(*
Got 4
Got 5
Got 11
Got 6
Got 7
Got 16
Got 28
Final: 28
*)