open Net_runtime;;

(**********************************************************************)
(* The type of trees                                                  *)
(**********************************************************************)

type tree =
    {         name         : string;
              is_directory : bool;
      mutable is_visible   : bool;
      mutable sub          : tree array
    } 
;;

(**********************************************************************)
(* common things                                                      *)
(**********************************************************************)

let re_slash = Str.regexp "/";;

let ( !! ) = Buffer.create;;          (* abbreviation *)

let message s =
  print_string s;
  flush stdout
;;


(**********************************************************************)
(* addresses of tree nodes                                            *)
(**********************************************************************)

let string_of_addr addr =
  String.concat "/" (List.map string_of_int addr)
;;


let addr_of_string str =
  List.map int_of_string (Str.split re_slash str)
;;


let change t addr value =
  (* change the is_visible flag in the node of t that is addressed by addr
   * to the new 'value'
   *)
  let rec visit t' =
    function
	[] -> t'.is_visible <- value
      |	a::addr -> visit (t'.sub.(a)) addr
  in
  visit t addr
;;


(**********************************************************************)
(* Convert a tree to an HTML table                                    *)
(**********************************************************************)

let rec width t =
  (* finds out the width of the tree *)
  
  let sub_width = 
    if t.is_visible
    then
      Array.fold_left (fun m b -> let mb = width b in max m mb) 0 t.sub
    else
      0
  in

  sub_width + 1
;;


let convert t =

  let width_t = width t in

  let text_height = 40 in

  let img which height =
    "<IMG SRC=\"" ^ which ^ "\" BORDER=0 HEIGHT=" ^ 
    string_of_int height ^ " WIDTH=40 SUPPRESS=\"TRUE\">"
  in

  let img_v  = img "vertical.gif" in
  let img_d  = img "diagonal.gif" in
  let img_vd = img "vert-diag.gif" in
  let img_op = img "open.gif" in
  let img_cl = img "close.gif" in

  let cell s = "<TD>" ^ s ^ "</TD>\n" in
  let text_cell s depth =
    "<TD VALIGN=BOTTOM COLSPAN=" ^ string_of_int (width_t - depth) ^
    ">" ^ s ^ "</TD>\n" in

  let anchor href s =
    "<A HREF=\"" ^ href ^ "\">" ^ s ^ "</A>" in

  let rec repeat s = 
    function
	[] -> !! ""
      |	b :: l' -> Buffer.concat [ !!(if b then s else cell ""); repeat s l']
  in

  let rec convert_subtree t' addr depth previous is_last_subtree =
    let vlines h p = repeat (cell (img_v h)) p in

    let previous' = 
      if depth > 0 then 
        previous @ [ not is_last_subtree ]
      else
	previous
    in

    let this_node =
      (* --- first line: label --- *)
      Buffer.concat
	[ !! "<TR>\n";
	  begin
          (* vertical lines, and a new branch *)
      	    if depth > 0 then begin
	      Buffer.concat
      	      	[ vlines text_height previous;
		  if is_last_subtree then
	    	    !! (cell (img_d text_height))
		  else
	    	    !! (cell (img_vd text_height))
		] 
      	    end
      	    else !! ""
	  end;
          (* the text *)
	  !! (text_cell t'.name depth);                 (* TODO: escape *)
	  !! "</TR>\n";
          (* --- second line: open/close button --- *)
	  if t'.is_directory then 
	    Buffer.concat
	      [ !! "<TR>\n";
    	      	vlines 26 previous';
    	  	begin
		  if t'.is_visible then
		    !! 
		      (cell 
			 (anchor 
			    ("javascript:parent.caml.change('close_sub_tree','" ^
			     string_of_addr addr ^ "')")
			    (img_cl 26)))
		  else
		    !!
		      (cell
	      		 (anchor 
			    ("javascript:parent.caml.change('open_sub_tree','" ^
			     string_of_addr addr ^ "')")
	      		    (img_op 26)))
	  	end;
	  	!! "</TR>\n"
	      ] 
      	  else !! ""
	] 
    (* this_node *)
    in

    let rec convert_sub_node k =
      if k >= Array.length t'.sub - 1 then
        convert_subtree t'.sub.(k) (addr @ [k]) (depth+1) previous' true
      else
	Buffer.concat
	  [ convert_subtree t'.sub.(k) (addr @ [k]) (depth+1) previous' false;
	    convert_sub_node (k+1)
	  ] 
    in

    if t'.is_directory & t'.is_visible & Array.length t'.sub > 0 then
      Buffer.concat [ this_node; convert_sub_node 0 ]
    else
      this_node 

  in

  Buffer.concat
    [ !! "<HTML><BODY>\n";
      !! "<TABLE CELLSPACING=0 BORDER=0 CELLPADDING=0>\n"; 
     convert_subtree t [] 0 [] true; 
      !! "</TABLE>\n";
      !! "</BODY></HTML>\n";
    ] 
;;


(**********************************************************************)
(* sample tree                                                        *)
(**********************************************************************)


let sample = 
  { name ="First";
    is_directory = true;
    is_visible = true;
    sub = [| { name = "Second";
	       is_directory = false;
	       is_visible = false;
	       sub = [| |] };
	     { name = "Third";
	       is_directory = true;
	       is_visible = false;
	       sub = [| |] };
	  |] }
;;

(**********************************************************************)
(* read tree from file                                                *)
(**********************************************************************)

let read_file name =
  let ch = open_in name in
  let t = { name = "top"; is_directory = true; is_visible = false;
	    sub = [| |] } in

  let rec enter t' l =

    let new_node new_name is_dir =
      let t_new = { name = new_name; is_directory = is_dir; is_visible = false;
		    sub = [| |] } in
      let a = 
	Array.append 
	  t'.sub 
	  [| t_new |]
      in
      t'.sub <- a;
      t_new
    in

    match l with 
      [] -> ()
    | [ dir_name; "" ] ->
	let _ = new_node dir_name true in ()
    | [ file_name ] ->
	let _ = new_node file_name false in ()
    | dir_name :: l' ->
	begin try
	  for i=0 to Array.length t'.sub-1 do
	    if t'.sub.(i).name = dir_name then
	    begin  enter t'.sub.(i) l'; raise Not_found end
	  done;
	  enter (new_node dir_name true) l'
	with
	  Not_found -> ()
	end
  in

  begin try
    while true do
      let line = input_line ch in
      print_string ("line: " ^ line ^ "\n");
      flush stdout;
      let fields = Str.split re_slash (line ^ "/") in
      enter t fields
    done;
    failwith "never coming to this point"
  with
    End_of_file ->
      close_in ch;
      t
  | any ->
      close_in ch;
      raise any
  end
;;


(**********************************************************************)
(* Callback functions                                                 *)
(**********************************************************************)

(* This is the global variable storing the current tree being edited *)


let global_tree = (ref None : tree option ref);;


let new_tree [| |] =
  (*  global_tree := Some sample; *)
  let t = read_file "tree.txt" in
  global_tree := Some t;
  Buffer.to_string (convert t)
;;


let open_sub_tree [| addr_string |] =
  match !global_tree with
    None ->
      failwith "Not initialized"
  | Some t ->
      let addr = addr_of_string addr_string in
      change t addr true;
      message "changed\n";
      let t' = convert t in
      message "converted\n";
      let s = Buffer.to_string t' in
      message "as string\n";
      s
;;


let close_sub_tree [| addr_string |] =
  match !global_tree with
    None ->
      failwith "Not initialized"
  | Some t ->
      let addr = addr_of_string addr_string in
      change t addr false;
      Buffer.to_string (convert t)
;;

(**********************************************************************)
(* main                                                               *)
(**********************************************************************)

let catch_all f args =
  try
    f args
  with
    Failure s ->
      "Failure " ^ s
  | Invalid_argument s ->
      "Invalid_argument " ^ s
  | Not_found ->
      "Not_found"
  | End_of_file ->
      "End_of_file"
  | Sys_error s ->
      "Sys_error " ^ s
  | Match_failure (s,n,m) ->
      "Match_failure " ^ s ^ "," ^ string_of_int n ^ "," ^ string_of_int m
  | Assert_failure (s,n,m) ->
      "Assert_failure " ^ s ^ "," ^ string_of_int n ^ "," ^ string_of_int m
  | _ ->
      "Uncaught Ocaml exception"

(*    any ->
      "Uncaught OCaml exception: " ^ Printexc.to_string any
*)
;;


register_callback "new_tree" 0 (catch_all new_tree);
register_callback "open_sub_tree" 1 (catch_all open_sub_tree);
register_callback "close_sub_tree" 1 (catch_all close_sub_tree);
sleep()
;;