mpri-funcprog-project/ocaml/Graph.ml

204 lines
5.2 KiB
OCaml
Raw Normal View History

2017-10-11 19:47:20 +02:00
open Printf
(* -------------------------------------------------------------------------- *)
(* A simple type of binary trees. *)
type tree =
| Leaf
| Node of { data: int; left: tree; right: tree }
(* -------------------------------------------------------------------------- *)
(* Constructors. *)
let node data left right =
Node { data; left; right }
let singleton data =
node data Leaf Leaf
(* -------------------------------------------------------------------------- *)
(* A sample tree. *)
let christmas =
node 6
(node 2 (singleton 0) (singleton 1))
(node 5 (singleton 3) (singleton 4))
(* -------------------------------------------------------------------------- *)
(* A test procedure. *)
let test name walk =
printf "Testing %s...\n%!" name;
walk christmas;
walk christmas;
flush stdout
(* -------------------------------------------------------------------------- *)
(* A recursive depth-first traversal, with postfix printing. *)
let rec walk (t : tree) : unit =
match t with
| Leaf ->
()
| Node { data; left; right } ->
walk left;
walk right;
printf "%d\n" data
let () =
test "walk" walk
(* -------------------------------------------------------------------------- *)
(* A CPS traversal. *)
let rec walkk (t : tree) (k : unit -> 'a) : 'a =
match t with
| Leaf ->
k()
| Node { data; left; right } ->
walkk left (fun () ->
walkk right (fun () ->
printf "%d\n" data;
k()))
let walk t =
walkk t (fun t -> t)
let () =
test "walkk" walk
(* -------------------------------------------------------------------------- *)
(* A CPS-defunctionalized traversal. *)
type kont =
| Init
| GoneL of { data: int; tail: kont; right: tree }
| GoneR of { data: int; tail: kont }
let rec walkkd (t : tree) (k : kont) : unit =
match t with
| Leaf ->
apply k ()
| Node { data; left; right } ->
walkkd left (GoneL { data; tail = k; right })
and apply k () =
match k with
| Init ->
()
| GoneL { data; tail; right } ->
walkkd right (GoneR { data; tail })
| GoneR { data; tail } ->
printf "%d\n" data;
apply tail ()
let walk t =
walkkd t Init
let () =
test "walkkd" walk
(* CPS, defunctionalized, with in-place allocation of continuations. *)
(* [Init] is encoded by [Leaf].
[GoneL { data; tail; right }] is encoded by:
- setting [status] to [GoneL]; and
- storing [tail] in the [left] field.
- the [data] and [right] fields retain their original value.
[GoneR { data; tail }] is encoded by:
- setting [status] to [GoneR]; and
- storing [tail] in the [right] field.
- the [data] and [left] fields retain their original value.
The [status] field is meaningful only when the memory block is
being viewed as a continuation. If it is being viewed as a tree,
then (by convention) [status] must be [GoneL]. (We could also
let the type [status] have three values, but I prefer to use just
two, for the sake of economy.)
Does that sound crazy? Well, it is, in a way. *)
type status = GoneL | GoneR
type mtree = Leaf | Node of {
data: int; mutable status: status;
mutable left: mtree; mutable right: mtree
}
type mkont = mtree
(* Constructors. *)
let node data left right =
Node { data; status = GoneL; left; right }
let singleton data =
node data Leaf Leaf
(* A sample tree. *)
let christmas =
node 6
(node 2 (singleton 0) (singleton 1))
(node 5 (singleton 3) (singleton 4))
(* A test. *)
let test name walk =
printf "Testing %s...\n%!" name;
walk christmas;
walk christmas;
flush stdout
(* The code. *)
let rec walkkdi (t : mtree) (k : mkont) : unit =
match t with
| Leaf ->
(* We decide to let [apply] takes a tree as a second argument,
instead of just a unit value. Indeed, in order to restore
the [left] or [right] fields of [k], we need the address
of the child [t] out of which we are coming. *)
apply k t
| Node ({ left; _ } as n) ->
(* At this point, [t] is a tree.
[n] is a name for its root record. *)
(* Change this tree to a [GoneL] continuation. *)
assert (n.status = GoneL);
n.left (* n.tail *) <- k;
(* [t] now represents a continuation. Go down into the left
child, with this continuation. *)
walkkdi left (t : mkont)
and apply (k : mkont) (child : mtree) : unit =
match k with
| Leaf -> ()
| Node ({ status = GoneL; left = tail; right; _ } as n) ->
(* We are popping a [GoneL] frame, that is, coming out of
a left child. *)
n.status <- GoneR; (* update continuation! *)
n.left <- child; (* restore orig. left child! *)
n.right (* n.tail *) <- tail;
(* [k] now represents a [GoneR] continuation. Go down into
the right child, with [k] as a continuation. *)
walkkdi right k
| Node ({ data; status = GoneR; right = tail; _ } as n) ->
printf "%d\n" data;
n.status <- GoneL; (* change back to a tree! *)
n.right <- child; (* restore orig. right child! *)
(* [k] now represents a valid tree again. *)
apply tail (k : mtree)
let walk t =
walkkdi t Leaf
let () =
test "walkkdi" walk