tree.ml

type 'a tree = Empty | Leaf of 'a | Node of 'a tree * 'a * 'a tree ;;

let rec tree_map f tree = 
  let rec aux t = match t with
  |  Empty  -> Empty
  |  Leaf value -> Leaf (f value)
  |  Node (l,value,r) -> Node ( aux l , f value, aux r) in
  aux tree

let rec preorder_print_tree tree = 
  let _ = Printf.printf "Preorder traversal:\n" in
  let rec aux t = match t with
  |  Empty  -> ()
  |  Leaf value -> Printf.printf "-%s" value
  |  Node (l,value,r) -> Printf.printf  "-%s-" value; aux l; aux r in
  aux tree; Printf.printf "\n"

let rec inorder_print_tree tree = 
  let _ = Printf.printf "Inorder traversal:\n" in
  let rec aux t = match t with
  |  Empty  -> ()
  |  Leaf value -> Printf.printf "-%s>" value
  |  Node (l,value,r) -> ( aux l );Printf.printf  "-%s-" value; aux r in
  aux tree; Printf.printf "\n"

let rec postorder_print_tree tree = 
  let _ = Printf.printf "Postorder traversal:\n" in
  let rec aux t = match t with
  |  Empty  -> ()
  |  Leaf value -> Printf.printf "-%s>" value
  |  Node (l,value,r) ->  aux l; aux r; Printf.printf  "-%s-" value  in
  aux tree; Printf.printf "\n"

(* simple fold for ints *)
(*
let rec fold_tree f acc t  =
         match t with 
         | Leaf x -> f x acc 0
         | Node (l,x,r) -> f x (fold_tree f acc l) (fold_tree f acc r);;
*)
 
(* better, more general *)
(*
let fold_tree f acc t = 
  let ^zero = acc in
  let rec aux f acc t  =
         match t with 
         | Leaf x -> f x acc z ero
         | Node (l,x,r) -> f x (aux f acc l) (aux f acc r) in
  aux f acc t ;;

let fold_tree_dot  acc t = 
  let rec aux  acc t  =
         match t with 
         | Leaf x ->   acc ^ x
         | Node (l,x,r) -> "{" ^ x ^ "->" ^ (aux  acc l) ^ "}\n {" ^ x ^ "->" ^ (aux  acc r) ^"}\n" in
  aux  acc t ;;
*)

let node_to_label n = match n with 
  | Empty -> "EMPTY"
  | Node(_,x,_) -> "{N"^x^"[label=\"" ^x^"\"]}"
  | Leaf x ->      "{L"^x^"[shape=box,label=\"" ^x^ "\"]}" ;;

let edge n1 n2 = (node_to_label n1)^"--"^(node_to_label n2)^"\n" ;;

(*
let fold_tree_dot  acc t = 
  let rec aux  acc t  =
         match t with 
         | Leaf x ->   acc ^ x
         | Node( Node (l,xl,r) as n , x,  Leaf xr) -> 
             "{"^x^"->"^xl^"}\n"^"{"^x^"->"^xr^"}\n" ^(aux acc n)
         | Node( (Leaf xl), x, (Node (l,xr,r) as n)  ) ->
             "{"^x^"->"^xl^"}\n"^"{"^x^"->"^xr^"}\n" ^(aux acc n)
         | Node( (Node (ll,xl,rl) as nl) , x, (Node(lr,xr,rr) as nr) ) -> 
             "{"^x^"->"^xl^"}\n"^"{"^x^"->"^xr^"}\n" ^(aux acc nl)^(aux acc nr)
         | Node (l,x,r) -> "{"^x ^ "->" ^ (aux  acc l) ^ "}\n{" ^ x ^ "->" ^ (aux  acc r) ^"}\n" in
  aux  acc t ;;
*)

let fold_tree_dot  acc tree = 
  let rec aux  acc t  =
         match t with 
         | Empty -> acc
         | Leaf _ as l ->   acc ^ (node_to_label l)
         | Node( (Node (_,_,_) as left) , _,  (Leaf _ as right))  -> 
              (edge t left) ^ (edge t right) ^(aux acc left)
         | Node( Leaf _ as left, _, (Node (_,_,_) as right))  ->
              (edge t left)^ (edge t right) ^ (aux acc right)
         | Node( ( Node(_,_,_)  as left) , _,  Empty)  -> 
              (edge t left) ^ (aux acc left)
         | Node( Empty, _, (Node(_,_,_) as right))  ->
              (edge t right) ^ (aux acc right)
         | Node( ( Leaf _  as n') , _,  Empty) | Node( Empty,  _,  (Leaf _ as n'))-> 
              (edge t n') 
         | Node( (Node (_,_,_) as nl) , _, (Node(_,_,_) as nr)) as n -> 
             (edge n nl)^(edge n nr)^(aux acc nl)^(aux acc nr)
         | Node (l,x,r) as n -> 
             (node_to_label n)^"--"^(aux acc l)^"\n"^(node_to_label n)^"--"^(aux acc r)^"\n" in
  aux  acc tree ;;

let tree_to_dotfile t file = 
  let dot_tree = "graph btree {\n"^(fold_tree_dot " " t)^"}" in
  let channel = open_out file in
  output_string channel dot_tree;
  close_out channel;;
let t = Node (
              Node (
                    Leaf "0", 
                    "1", 
                    Leaf "2"), 
              "3", 
              Node (
                    Leaf "4", 
                    "5", 
                    Node (
                          Node(Leaf "6", "7", Empty), 
                          "8", 
                          Empty)
              ) 
         )
let tree' =  tree_map ( fun x -> Printf.printf " %s\n" x; x ^ x) t 
let _ = tree_to_dotfile t "tree.dot" ;
        preorder_print_tree t;
        inorder_print_tree t;
        postorder_print_tree t