(*module Debug = Camlp4.Debug*)
open Module2d

type canvas = string array

let w = 500
let h = 20

let fresh () = Array.create h ""

let print_line oc s =
  let l = ref 0 in
  for i = 0 to String.length s - 1 do if s.[i] <> ' ' then l := i done;
  output_string oc (String.sub s 0 (succ !l));
  output_string oc "\n"

let print oc c =
  let lines = ref 0 in
  Array.iter (function "" -> () | s -> incr lines; print_line oc s) c;
  Printf.eprintf "%i lines\n" !lines
  
let get c x y = 
  try if c.(y) = "" then ' ' else c.(y).[x] with _ -> ' '

let remove_col c x =
  try for y = 0 to Array.length c - 1 do
    match get c (x-1) y, get c x y, get c (x+1) y with
      | '+', ' ', '+' -> raise Exit
      | '!', ' ', '+' -> raise Exit
      | '+', ' ', '!' -> raise Exit
      | '!', '-', '>' -> raise Exit
      | _, (' ' | '-' | '.'), _ -> ()
      | _ -> raise Exit
  done; true
  with Exit -> false
  
let compact c =
  for x = w - 1 downto 0 do
    if remove_col c x then
      for y = 0 to Array.length c - 1 do
	let s = c.(y) in
	if s = "" then ()
	else c.(y) <- 
	  (String.sub s 0 x) ^ 
	  (String.sub s (succ x) (String.length s - x - 1))
      done;
  done

  



let set c x y ch =
  try
  assert(x < w);
  assert(y < h);
  assert(x >= 0);
  assert(y >= 0);
  assert(Array.length c = h);
  if c.(y) = "" then c.(y) <- String.make w ' ';
  c.(y).[x] <-
    match (c.(y).[x],ch) with
      | '-','|' | '|','-' -> '#'
      | '|', '+' -> assert false
      | '+', '|' -> assert false
      | ('+'|'-'),':' -> '-'
      | '+','.' -> '|'
      | '|','.' -> '|'
      | _ -> ch
  with _ -> (Format.eprintf "y:%d@." y)

let draw_line c x y w ch =
  for i = 0 to w - 1 do set c (x+i) y ch done

let draw_vline c x y h ch =
  for i = 0 to h - 1 do set c x (y+i) ch done

let draw_string c x y s =
  for i = 0 to String.length s - 1 do set c (x+i) y s.[i] done

let draw_box c x y label =
  let n = String.length label in
  let x2 = x+n+1 in
  set c x y '*';
  set c x2 y '*';
  set c x (y+2) '*';
  set c x2 (y+2) '*';
  set c x (y+1) '!';
  set c x2 (y+1) '!';
  draw_line c (x+1) y n '=';
  draw_line c (x+1) (y+2) n '=';
  draw_string c (x+1) (y+1) label

let draw_module c x y w h label =
  set c x y ',';
  draw_line c (x+1) y (w-2) '.';
  set c (x+w-1) y ',';
  set c x (y+h-1) ',';
  draw_line c (x+1) (y+h-1) (w-2) '.';
  set c (x+w-1) (y+h-1) ',';
  draw_vline c x (y+1) (h-2) ':';
  draw_vline c (x+w-1) (y+1) (h-2) ':';
  draw_string c (x+1) (y+1) label

let horiz c x1 x2 y =
  if x1 >= x2 then Printf.eprintf "x1=%i x2=%i\n" x1 x2 else (
  assert(x1 < x2);
  set c x1 y '+';
  draw_line c (x1+1) y (x2-x1-1) '-';
  set c x2 y '+'
  )

let vertic c x y1 y2 =
  set c x y1 '+';
  draw_vline c x (y1+1) (y2-y1-1) '|';
  set c x y2 '+'

let connect_w c x y =
  set c (x-1) (y+1) '>';
  set c (x-2) (y+1) '-';
  (x-3, y+1)

let connect_n c x y =
  draw_string c x (y-2)       "++";
  draw_string c (x-1) (y-1)  "-+v";
  (x-2,y-1)

let connect_e c x y y2 =
  vertic c (x+1) (y+1) y2;
  x+1

let connect_s c x y y2 =
  draw_vline c (x-1) (y+3) (y2-y-3) '|';
  set c (x-1) y2 '+';
  (x-1)

type dst = N of int | W of int | Out


let draw_module c x0 y0 m =
  let x = ref (x0 + 4 + String.length m.name) in
  if m.boxes.(0).in_w = None &&
    m.boxes.(0).in_n <> Some In_w
  then x := x0+1;
  let x1 = Array.map (fun _ -> 0) m.boxes in
  let x2 = Array.map (fun _ -> 0) m.boxes in
  let y = Array.map (fun _ -> (y0+3)) m.boxes in
  let conn_y = ref (y0+6) in

  let connect src dst =
    match src,dst with
      | Out_e i1, Out when i1 == Array.length m.boxes - 1 ->
	  draw_line c (x2.(i1)+1) (y.(i1)+1) (!x - x2.(i1) - 1) '-';
      | In_n, N i2 ->
	  draw_vline c (x2.(i2)-1) y0 (y.(i2)-y0) '|';
	  set c (x2.(i2)-1) (y.(i2)-1) 'v'
      | Out_e i1, W i2 when i2 = i1 + 1 ->
	  set c (x1.(i2)-1) (y.(i2)+1) '>';
	  draw_line c (x2.(i1)+1) (y.(i1)+1) (x1.(i2)-x2.(i1)-2) '-' 
    | _ ->
    let dx2,dy2 = match dst with
      | W i2 -> connect_w c x1.(i2) y.(i2)
      | N i2 -> connect_n c x1.(i2) y.(i2)
      | Out -> (!x-1,-1)
    in
    if src = In_n then
      vertic c dx2 y0 dy2
    else
      let dx1 = match src with
	| Out_e i1 -> x2.(i1) + 1
	| Out_s i1 -> x2.(i1) - 1
	| In_w -> x0
	| In_n -> assert false in
      (* Chercher ligne qui peut heberger le segment  dx1 <---> dx2 *)
      let rec search y2 =
	try
	  for x = dx1 to dx2 do 
	    match get c x y2 with
	      | '|' | ' ' -> ()
	      | _ -> raise Exit
	  done;
	  conn_y := max !conn_y y2;
	  y2
	with Exit -> search (succ y2)
      in
      let y2 = search (y0 + 6) in
      let dy2 = if dy2 = -1 then y2 else dy2 in
      assert( dx1 = match src with
		| Out_e i1 -> assert(x2.(i1) > 0); 
		    connect_e c x2.(i1) y.(i1) y2
		| Out_s i1 -> assert(x2.(i1) > 0); 
		    connect_s c x2.(i1) y.(i1) y2
		| In_w -> x0
		| In_n -> assert false );
      horiz c dx1 dx2 y2;
      vertic c dx2 dy2 y2;
  in

  let box i b =
    let e1 = !x in
    let e2 = e1 + String.length b.label + 1 in
    draw_box c e1 y.(i) b.label;
    x1.(i) <- !x;
    x2.(i) <- e2;
    x := e2 + 8;

    (match b.in_w with
       | Some r -> connect r (W i)
       | None -> ());
    (match b.in_n with
       | Some r -> connect r (N i)
       | None -> ());

  in
  Array.iteri box m.boxes;
  x := !x - 5;
  List.iter (fun x -> connect x Out) m.outputs;
  draw_module c x0 y0 (!x - x0) (!conn_y - y0 + 2) m.name

let draw_module oc m =
  let c = fresh () in
  draw_module c 0 0 m;
  compact c;
  print oc c

let dump_module f m =
  Format.fprintf f "module: %S\n" m.name;
  let src = function
    | In_n -> Format.fprintf f "In_n\n"
    | In_w -> Format.fprintf f "In_w\n"
    | Out_e i -> Format.fprintf f "Out_e %i\n" i
    | Out_s i -> Format.fprintf f "Out_s %i\n" i in
  let box i b =
    Format.fprintf f " box [%i] %S\n" i b.label;
    (match b.in_w with Some x -> Format.fprintf f "  w <- "; src x | None -> ());
    (match b.in_n with Some x -> Format.fprintf f "  n <- "; src x | None -> ())
  in
  Array.iteri box m.boxes;
  List.iter (fun x -> Format.fprintf f " out <- "; src x) m.outputs

let dump_modules f l =
  List.iter (dump_module f) l

let draw_modules oc l = 
  try List.iter (draw_module oc) l
  with exn -> prerr_endline "Exception in Canvas"; raise exn