-
Notifications
You must be signed in to change notification settings - Fork 36
Expand file tree
/
Copy pathnondeterminism.ml
More file actions
121 lines (92 loc) · 3.68 KB
/
nondeterminism.ml
File metadata and controls
121 lines (92 loc) · 3.68 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
(* This example is adapted from Kammar et. al (2013) *)
open Effect
(** Coin flipping -- non-determinism as an algebraic effect **)
open Effect.Deep
(* Non-determinism is an effect given by an operation Choose, that
returns a boolean. *)
type _ eff += Choose : bool eff
let choose () = perform Choose
(* An example non-deterministic computation: A coin toss *)
type toss = Heads | Tails
let toss () = if choose () then Heads else Tails
(* Fixed interpretations *)
let make_charged_handler (b : bool) m =
match m () with
| x -> x
| effect Choose, k -> continue k b
let positive = make_charged_handler true (* always interpret as true *)
let negative = make_charged_handler false (* always interpret as false *)
(* [all_results] enumerates every possible outcome of a
non-deterministic computation *)
let all_results m =
match m () with
| v -> [ v ]
| effect Choose, k ->
continue k true
@ continue (Multicont.Deep.clone_continuation k) false
(* OCaml effects/multicore only supports single-shot
continuations. But, we can simulate multi-shot continuations by
copying a continuation (using Obj.clone) before invocation. *)
(* Random interpretation *)
let coin m =
match m () with
| x -> x
| effect Choose, k -> continue k (Random.float 1.0 > 0.5)
(* Another example: A drunken coin toss. A drunkard may fail to catch
the coin. *)
exception Too_drunk
let too_drunk () = raise Too_drunk
let drunk_toss () = if choose () then too_drunk () else toss ()
(* This exception handler returns Some result if [m] was successful,
otherwise it returns None. *)
let optionalize m = try Some (m ()) with Too_drunk -> None
(* This exception handler restarts [m] whenever it fails. *)
let rec persevere m = try m () with Too_drunk -> persevere m
(* The pipeline operator combines two handlers [h] and [g]. Data flows
from [g] to [h]. *)
let ( -<- ) h g m = h (fun () -> g m)
(* Running some examples + boilerplate conversions *)
let string_of_toss = function Heads -> "Heads" | Tails -> "Tails"
let string_of_list string_of_e xs =
let xs = List.map string_of_e xs in
"["
^ (if List.length xs > 1 then
List.fold_left (fun xs x -> xs ^ ", " ^ x) (List.hd xs) (List.tl xs)
else List.hd xs)
^ "]"
let string_of_option string_of_e = function
| Some e -> "Some (" ^ string_of_e e ^ ")"
| None -> "None"
let run_examples () =
print_endline (">> positive toss : " ^ string_of_toss (positive toss));
print_endline (">> negative toss : " ^ string_of_toss (negative toss));
print_endline
(">> all_results toss: " ^ string_of_list string_of_toss (all_results toss));
print_endline (">> coin toss : " ^ string_of_toss (coin toss));
print_endline
(">> toss |> optionalize -<- all_results : "
^ string_of_option
(string_of_list string_of_toss)
(toss |> optionalize -<- all_results));
print_endline
(">> toss |> all_results -<- optionalize : "
^ string_of_list
(string_of_option string_of_toss)
(toss |> all_results -<- optionalize));
print_endline
(">> drunk_toss |> optionalize -<- all_results : "
^ string_of_option
(string_of_list string_of_toss)
(drunk_toss |> optionalize -<- all_results));
print_endline
(">> drunk_toss |> all_results -<- optionalize : "
^ string_of_list
(string_of_option string_of_toss)
(drunk_toss |> all_results -<- optionalize));
print_endline
(">> drunk_toss |> optionalize -<- coin : "
^ string_of_option string_of_toss (drunk_toss |> optionalize -<- coin));
print_endline
(">> drunk_toss |> peservere -<- coin : "
^ string_of_toss (drunk_toss |> persevere -<- coin))
let _ = run_examples ()