odoc_dag2html.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Maxence Guesdon, projet Cristal, INRIA Rocquencourt        *)
(*                                                                        *)
(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *)

type 'a dag = { mutable dag : 'a node array }
and 'a node =
  { mutable pare : idag list; valu : 'a; mutable chil : idag list }
and idag = int

external int_of_idag : idag -> int = "%identity"
external idag_of_int : int -> idag = "%identity"

type 'a table = { table : 'a data array array }
and 'a data = { mutable elem : 'a elem; mutable span : span_id }
and 'a elem = Elem of 'a | Ghost of ghost_id | Nothing
and span_id
and ghost_id

external span_id_of_int : int -> span_id = "%identity"
external ghost_id_of_int : int -> ghost_id = "%identity"

let new_span_id = let i = ref 0 in fun () -> incr i; span_id_of_int !i

let new_ghost_id = let i = ref 0 in fun () -> incr i; ghost_id_of_int !i

(** creating the html table structure *)

type align = LeftA | CenterA | RightA
type table_data = TDstring of string | TDhr of align

let html_table_struct indi_txt phony d t =
  let phony =
    function
      Elem e -> phony d.dag.(int_of_idag e)
    | Ghost _ -> false
    | Nothing -> true
  in
  let elem_txt =
    function
      Elem e -> indi_txt d.dag.(int_of_idag e)
    | Ghost _ -> "|"
    | Nothing -> " "
  in
  let bar_txt =
    function
      Elem _ | Ghost _ -> "|"
    | Nothing -> " "
  in
  let all_empty i =
    let rec loop j =
      if j = Array.length t.table.(i) then true
      else
        match t.table.(i).(j).elem with
          Nothing -> loop (j + 1)
        | e -> if phony e then loop (j + 1) else false
    in
    loop 0
  in
  let line_elem_txt i =
    let les =
      let rec loop les j =
        if j = Array.length t.table.(i) then les
        else
          let x = t.table.(i).(j) in
          let next_j =
            let rec loop j =
              if j = Array.length t.table.(i) then j
              else if t.table.(i).(j) = x then loop (j + 1)
              else j
            in
            loop (j + 1)
          in
          let colspan = 3 * (next_j - j) in
          let les = (1, LeftA, TDstring " ") :: les in
          let les =
            let s =
              if t.table.(i).(j).elem = Nothing then " "
              else elem_txt t.table.(i).(j).elem
            in
            (colspan - 2, CenterA, TDstring s) :: les
          in
          let les = (1, LeftA, TDstring " ") :: les in loop les next_j
      in
      loop [] 0
    in
    Array.of_list (List.rev les)
  in
  let vbars_txt k i =
    let les =
      let rec loop les j =
        if j = Array.length t.table.(i) then les
        else
          let x = t.table.(i).(j) in
          let next_j =
            let rec loop j =
              if j = Array.length t.table.(i) then j
              else if t.table.(i).(j) = x then loop (j + 1)
              else j
            in
            loop (j + 1)
          in
          let colspan = 3 * (next_j - j) in
          let les = (1, LeftA, TDstring " ") :: les in
          let les =
            let s =
              if k > 0 && t.table.(k - 1).(j).elem = Nothing ||
                 t.table.(k).(j).elem = Nothing then
                " "
              else if phony t.table.(i).(j).elem then " "
              else bar_txt t.table.(i).(j).elem
            in
            (colspan - 2, CenterA, TDstring s) :: les
          in
          let les = (1, LeftA, TDstring " ") :: les in loop les next_j
      in
      loop [] 0
    in
    Array.of_list (List.rev les)
  in
  let alone_bar_txt i =
    let les =
      let rec loop les j =
        if j = Array.length t.table.(i) then les
        else
          let next_j =
            let x = t.table.(i).(j).span in
            let rec loop j =
              if j = Array.length t.table.(i) then j
              else if t.table.(i).(j).span = x then loop (j + 1)
              else j
            in
            loop (j + 1)
          in
          let colspan = 3 * (next_j - j) - 2 in
          let les = (1, LeftA, TDstring " ") :: les in
          let les =
            if t.table.(i).(j).elem = Nothing ||
               t.table.(i + 1).(j).elem = Nothing then
              (colspan, LeftA, TDstring " ") :: les
            else
              let s =
                let all_ph =
                  let rec loop j =
                    if j = next_j then true
                    else if phony t.table.(i + 1).(j).elem then loop (j + 1)
                    else false
                  in
                  loop j
                in
                if all_ph then " " else "|"
              in
              (colspan, CenterA, TDstring s) :: les
          in
          let les = (1, LeftA, TDstring " ") :: les in loop les next_j
      in
      loop [] 0
    in
    Array.of_list (List.rev les)
  in
  let exist_several_branches i k =
    let rec loop j =
      if j = Array.length t.table.(i) then false
      else
        let x = t.table.(i).(j).span in
        let e = t.table.(k).(j).elem in
        let rec loop1 j =
          if j = Array.length t.table.(i) then false
          else if t.table.(i).(j).elem = Nothing then loop j
          else if t.table.(i).(j).span <> x then loop j
          else if t.table.(k).(j).elem <> e then true
          else loop1 (j + 1)
        in
        loop1 (j + 1)
    in
    loop 0
  in
  let hbars_txt i k =
    let les =
      let rec loop les j =
        if j = Array.length t.table.(i) then les
        else
          let next_j =
            let e = t.table.(i).(j).elem in
            let x = t.table.(i).(j).span in
            let rec loop j =
              if j = Array.length t.table.(i) then j
              else if e = Nothing && t.table.(i).(j).elem = Nothing then
                loop (j + 1)
              else if t.table.(i).(j).span = x then loop (j + 1)
              else j
            in
            loop (j + 1)
          in
          let rec loop1 les l =
            if l = next_j then loop les next_j
            else
              let next_l =
                let y = t.table.(k).(l) in
                match y.elem with
                  Elem _ | Ghost _ ->
                    let rec loop l =
                      if l = Array.length t.table.(i) then l
                      else if t.table.(k).(l) = y then loop (l + 1)
                      else l
                    in
                    loop (l + 1)
                | _ -> l + 1
              in
              if next_l > next_j then
                begin
                  Printf.eprintf
                    "assert false i %d k %d l %d next_l %d next_j %d\n" i k l
                    next_l next_j;
                  flush stderr
                end;
              let next_l = Int.min next_l next_j in
              let colspan = 3 * (next_l - l) - 2 in
              let les =
                match t.table.(i).(l).elem, t.table.(i + 1).(l).elem with
                  Nothing, _ | _, Nothing ->
                    (colspan + 2, LeftA, TDstring "&nbsp;") :: les
                | _ ->
                    let ph s =
                      if phony t.table.(k).(l).elem then TDstring "&nbsp;"
                      else s
                    in
                    if l = j && next_l = next_j then
                      let les = (1, LeftA, TDstring "&nbsp;") :: les in
                      let s = ph (TDstring "|") in
                      let les = (colspan, CenterA, s) :: les in
                      let les = (1, LeftA, TDstring "&nbsp;") :: les in les
                    else if l = j then
                      let les = (1, LeftA, TDstring "&nbsp;") :: les in
                      let s = ph (TDhr RightA) in
                      let les = (colspan, RightA, s) :: les in
                      let s = ph (TDhr CenterA) in
                      let les = (1, LeftA, s) :: les in les
                    else if next_l = next_j then
                      let s = ph (TDhr CenterA) in
                      let les = (1, LeftA, s) :: les in
                      let s = ph (TDhr LeftA) in
                      let les = (colspan, LeftA, s) :: les in
                      let les = (1, LeftA, TDstring "&nbsp;") :: les in les
                    else
                      let s = ph (TDhr CenterA) in
                      (colspan + 2, LeftA, s) :: les
              in
              loop1 les next_l
          in
          loop1 les j
      in
      loop [] 0
    in
    Array.of_list (List.rev les)
  in
  let hts =
    let rec loop hts i =
      if i = Array.length t.table then hts
      else if i = Array.length t.table - 1 && all_empty i then hts
      else
        let hts = line_elem_txt i :: hts in
        let hts =
          if i < Array.length t.table - 1 then
            let hts = vbars_txt (i + 1) i :: hts in
            let hts =
              if exist_several_branches i i then
                alone_bar_txt i :: hbars_txt i i :: hts
              else hts
            in
            let hts =
              if exist_several_branches i (i + 1) &&
                 (i < Array.length t.table - 2 ||
                  not (all_empty (i + 1))) then
                vbars_txt (i + 1) (i + 1) :: hbars_txt i (i + 1) :: hts
              else hts
            in
            hts
          else hts
        in
        loop hts (i + 1)
    in
    loop [] 0
  in
  Array.of_list (List.rev hts)

(** transforming dag into table *)

let ancestors d =
  let rec loop i =
    if i = Array.length d.dag then []
    else
      let n = d.dag.(i) in
      if n.pare = [] then idag_of_int i :: loop (i + 1) else loop (i + 1)
  in
  loop 0

let get_children d parents =
  (* XXXX merge_children used to be declared as a recursive function,
     but it was not.  I've no idea if it is a bug or not.  One should
     either fix it (if this is a bug), or simplify the code otherwise. *)

  let merge_children children el =
    List.fold_right
      (fun (x, _) children ->
         match x with
           Elem e ->
             let e = d.dag.(int_of_idag e) in
             List.fold_right
               (fun c children ->
                  if List.mem c children then children else c :: children)
               e.chil children
         | _ -> [])
      el children
  in
  merge_children [] parents

let rec get_block t i j =
  if j = Array.length t.table.(i) then None
  else if j = Array.length t.table.(i) - 1 then
    let x = t.table.(i).(j) in Some ([x.elem, 1], 1, x.span)
  else
    let x = t.table.(i).(j) in
    let y = t.table.(i).(j + 1) in
    if y.span = x.span then
      match get_block t i (j + 1) with
        Some ((x1, c1) :: list, mpc, span) ->
          let (list, mpc) =
            if x1 = x.elem then (x1, c1 + 1) :: list, Int.max mpc (c1 + 1)
            else (x.elem, 1) :: (x1, c1) :: list, Int.max mpc c1
          in
          Some (list, mpc, span)
      | _ -> assert false
    else Some ([x.elem, 1], 1, x.span)

let group_by_common_children d list =
  let module O =
    struct
      type t = idag
      let compare (x:t) y = compare x y
     end
  in
  let module S = Set.Make (O)
  in
  let nlcsl =
    List.map
      (fun id ->
         let n = d.dag.(int_of_idag id) in
         let cs = List.fold_right S.add n.chil S.empty in [id], cs)
      list
  in
  let nlcsl =
    let rec loop =
      function
        [] -> []
      | (nl, cs) :: rest ->
          let rec loop1 beg =
            function
              (nl1, cs1) :: rest1 ->
                if S.is_empty (S.inter cs cs1) then
                  loop1 ((nl1, cs1) :: beg) rest1
                else
                  loop ((nl @ nl1, S.union cs cs1) :: (List.rev beg @ rest1))
            | [] -> (nl, cs) :: loop rest
          in
          loop1 [] rest
    in
    loop nlcsl
  in
  List.fold_right
    (fun (nl, _) a ->
       let span = new_span_id () in
       List.fold_right (fun n a -> {elem = Elem n; span = span} :: a) nl a)
    nlcsl []

let copy_data d = {elem = d.elem; span = d.span}

let insert_columns t nb j =
  let t1 = Array.make (Array.length t.table) [| |] in
  for i = 0 to Array.length t.table - 1 do
    let line = t.table.(i) in
    let line1 = Array.make (Array.length line + nb) line.(0) in
    t1.(i) <- line1;
    let rec loop k =
      if k = Array.length line then ()
      else
        begin
          if k < j then line1.(k) <- copy_data line.(k)
          else if k = j then
            for r = 0 to nb do line1.(k + r) <- copy_data line.(k) done
          else line1.(k + nb) <- copy_data line.(k);
          loop (k + 1)
        end
    in
    loop 0
  done;
  {table = t1}

let rec gcd a b =
  if a < b then gcd b a else if b = 0 then a else gcd b (a mod b)

let treat_new_row d t =
  let i = Array.length t.table - 1 in
  let rec loop t i j =
    match get_block t i j with
      Some (parents, max_parent_colspan, _span) ->
        let children = get_children d parents in
        let children =
          if children = [] then [{elem = Nothing; span = new_span_id ()}]
          else
            List.map (fun n -> {elem = Elem n; span = new_span_id ()})
              children
        in
        let simple_parents_colspan =
          List.fold_left (fun x (_, c) -> x + c) 0 parents
        in
        if simple_parents_colspan mod List.length children = 0 then
          let j = j + simple_parents_colspan in
          let children =
            let cnt = simple_parents_colspan / List.length children in
            List.fold_right
              (fun d list ->
                 let rec loop cnt list =
                   if cnt = 1 then d :: list
                   else copy_data d :: loop (cnt - 1) list
                 in
                 loop cnt list)
              children []
          in
          let (t, children_rest) = loop t i j in t, children @ children_rest
        else
          let parent_colspan =
            List.fold_left
              (fun scm (_, c) -> let g = gcd scm c in scm / g * c)
              max_parent_colspan parents
          in
          let (t, parents, _) =
            List.fold_left
              (fun (t, parents, j) (x, c) ->
                 let to_add = parent_colspan / c - 1 in
                 let t =
                   let rec loop cc t j =
                     if cc = 0 then t
                     else
                       let t = insert_columns t to_add j in
                       loop (cc - 1) t (j + to_add + 1)
                   in
                   loop c t j
                 in
                 t, (x, parent_colspan) :: parents, j + parent_colspan)
              (t, [], j) parents
          in
          let parents = List.rev parents in
          let parents_colspan = parent_colspan * List.length parents in
          let children_colspan = List.length children in
          let g = gcd parents_colspan children_colspan in
          let (t, j) =
            let cnt = children_colspan / g in
            List.fold_left
              (fun (t, j) (_, c) ->
                 let rec loop cc t j =
                   if cc = 0 then t, j
                   else
                     let t = insert_columns t (cnt - 1) j in
                     let j = j + cnt in loop (cc - 1) t j
                 in
                 loop c t j)
              (t, j) parents
          in
          let children =
            let cnt = parents_colspan / g in
            List.fold_right
              (fun d list ->
                 let rec loop cnt list =
                   if cnt = 0 then list else d :: loop (cnt - 1) list
                 in
                 loop cnt list)
              children []
          in
          let (t, children_rest) = loop t i j in t, children @ children_rest
    | None -> t, []
  in
  loop t i 0

let down_it t i k =
  t.table.(Array.length t.table - 1).(k) <- t.table.(i).(k);
  for r = i to Array.length t.table - 2 do
    t.table.(r).(k) <- {elem = Ghost (new_ghost_id ()); span = new_span_id ()}
  done

(* equilibrate:
   in the last line, for all elem A, make fall all As, which are located at
   its right side above, to its line,
                             A             |
   i.e. transform all        . into        |
                      A.......      A......A
*)

let equilibrate t =
  let ilast = Array.length t.table - 1 in
  let last = t.table.(ilast) in
  let len = Array.length last in
  let rec loop j =
    if j = len then ()
    else
      match last.(j).elem with
        Elem x ->
          let rec loop1 i =
            if i = ilast then loop (j + 1)
            else
              let rec loop2 k =
                if k = len then loop1 (i + 1)
                else
                  match t.table.(i).(k).elem with
                    Elem y when x = y -> down_it t i k; loop 0
                  | _ -> loop2 (k + 1)
              in
              loop2 0
          in
          loop1 0
      | _ -> loop (j + 1)
  in
  loop 0

(* group_elem:
   transform all x y into x x
                 A A      A A *)

let group_elem t =
  for i = 0 to Array.length t.table - 2 do
    for j = 1 to Array.length t.table.(0) - 1 do
      match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with
        Elem x, Elem y when x = y ->
          t.table.(i).(j).span <- t.table.(i).(j - 1).span
      | _ -> ()
    done
  done

(* group_ghost:
                 x  x       x  x           |a |a      |a |a
   transform all |a |b into |a |a and all  x  y  into x  x
                 y  z       y  y           A  A       A  A  *)

let group_ghost t =
  for i = 0 to Array.length t.table - 2 do
    for j = 1 to Array.length t.table.(0) - 1 do
      begin match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with
        Ghost x, Ghost _ ->
          if t.table.(i).(j - 1).span = t.table.(i).(j).span then
            t.table.(i + 1).(j) <-
              {elem = Ghost x; span = t.table.(i + 1).(j - 1).span}
      | _ -> ()
      end;
      match t.table.(i).(j - 1).elem, t.table.(i).(j).elem with
        Ghost x, Ghost _ ->
          if t.table.(i + 1).(j - 1).elem = t.table.(i + 1).(j).elem then
            begin
              t.table.(i).(j) <-
                {elem = Ghost x; span = t.table.(i).(j - 1).span};
              if i > 0 then
                t.table.(i - 1).(j).span <- t.table.(i - 1).(j - 1).span
            end
      | _ -> ()
    done
  done

(* group_children:
   transform all A A into A A
                 x y      x x *)

let group_children t =
  for i = 0 to Array.length t.table - 1 do
    let line = t.table.(i) in
    let len = Array.length line in
    for j = 1 to len - 1 do
      if line.(j).elem = line.(j - 1).elem && line.(j).elem <> Nothing then
        line.(j).span <- line.(j - 1).span
    done
  done

(* group_span_by_common_children:
   in the last line, transform all
     A B into A B
     x y      x x
   if A and B have common children *)

let group_span_by_common_children d t =
  let module O =
    struct
      type t = idag
      let compare (x:t) y = compare x y
    end
  in
  let module S = Set.Make (O)
  in
  let i = Array.length t.table - 1 in
  let line = t.table.(i) in
  let rec loop j cs =
    if j = Array.length line then ()
    else
      match line.(j).elem with
        Elem id ->
          let n = d.dag.(int_of_idag id) in
          let curr_cs = List.fold_right S.add n.chil S.empty in
          if S.is_empty (S.inter cs curr_cs) then loop (j + 1) curr_cs
          else
            begin
              line.(j).span <- line.(j - 1).span;
              loop (j + 1) (S.union cs curr_cs)
            end
      | _ -> loop (j + 1) S.empty
  in
  loop 0 S.empty

let find_same_parents t i j1 j2 j3 j4 =
  let rec loop i j1 j2 j3 j4 =
    if i = 0 then i, j1, j2, j3, j4
    else
      let x1 = t.(i - 1).(j1) in
      let x2 = t.(i - 1).(j2) in
      let x3 = t.(i - 1).(j3) in
      let x4 = t.(i - 1).(j4) in
      if x1.span = x4.span then i, j1, j2, j3, j4
      else
        let j1 =
          let rec loop j =
            if j < 0 then 0
            else if t.(i - 1).(j).span = x1.span then loop (j - 1)
            else j + 1
          in
          loop (j1 - 1)
        in
        let j2 =
          let rec loop j =
            if j >= Array.length t.(i) then j - 1
            else if t.(i - 1).(j).span = x2.span then loop (j + 1)
            else j - 1
          in
          loop (j2 + 1)
        in
        let j3 =
          let rec loop j =
            if j < 0 then 0
            else if t.(i - 1).(j).span = x3.span then loop (j - 1)
            else j + 1
          in
          loop (j3 - 1)
        in
        let j4 =
          let rec loop j =
            if j >= Array.length t.(i) then j - 1
            else if t.(i - 1).(j).span = x4.span then loop (j + 1)
            else j - 1
          in
          loop (j4 + 1)
        in
        loop (i - 1) j1 j2 j3 j4
  in
  loop i j1 j2 j3 j4

let find_linked_children t i j1 j2 j3 j4 =
  let rec loop i j1 j2 j3 j4 =
    if i = Array.length t - 1 then j1, j2, j3, j4
    else
      let x1 = t.(i).(j1) in
      let x2 = t.(i).(j2) in
      let x3 = t.(i).(j3) in
      let x4 = t.(i).(j4) in
      let j1 =
        let rec loop j =
          if j < 0 then 0
          else if t.(i).(j).span = x1.span then loop (j - 1)
          else j + 1
        in
        loop (j1 - 1)
      in
      let j2 =
        let rec loop j =
          if j >= Array.length t.(i) then j - 1
          else if t.(i).(j).span = x2.span then loop (j + 1)
          else j - 1
        in
        loop (j2 + 1)
      in
      let j3 =
        let rec loop j =
          if j < 0 then 0
          else if t.(i).(j).span = x3.span then loop (j - 1)
          else j + 1
        in
        loop (j3 - 1)
      in
      let j4 =
        let rec loop j =
          if j >= Array.length t.(i) then j - 1
          else if t.(i).(j).span = x4.span then loop (j + 1)
          else j - 1
        in
        loop (j4 + 1)
      in
      loop (i + 1) j1 j2 j3 j4
  in
  loop i j1 j2 j3 j4

let mirror_block t i1 i2 j1 j2 =
  for i = i1 to i2 do
    let line = t.(i) in
    let rec loop j1 j2 =
      if j1 >= j2 then ()
      else
        let v = line.(j1) in
        line.(j1) <- line.(j2); line.(j2) <- v; loop (j1 + 1) (j2 - 1)
    in
    loop j1 j2
  done

let exch_blocks t i1 i2 j1 j2 j3 j4 =
  for i = i1 to i2 do
    let line = t.(i) in
    let saved = Array.copy line in
    for j = j1 to j2 do line.(j4 - j2 + j) <- saved.(j) done;
    for j = j3 to j4 do line.(j1 - j3 + j) <- saved.(j) done
  done

let find_block_with_parents t i jj1 jj2 jj3 jj4 =
  let rec loop ii jj1 jj2 jj3 jj4 =
    let (nii, njj1, njj2, njj3, njj4) =
      find_same_parents t i jj1 jj2 jj3 jj4
    in
    if nii <> ii || njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 ||
       njj4 <> jj4 then
      let nii = Int.min ii nii in
      let (jj1, jj2, jj3, jj4) =
        find_linked_children t nii njj1 njj2 njj3 njj4
      in
      if njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 || njj4 <> jj4 then
        loop nii jj1 jj2 jj3 jj4
      else nii, jj1, jj2, jj3, jj4
    else ii, jj1, jj2, jj3, jj4
  in
  loop i jj1 jj2 jj3 jj4

let push_to_right t i j1 j2 =
  let line = t.(i) in
  let rec loop j =
    if j = j2 then j - 1
    else
      let ini_jj1 =
        match line.(j - 1).elem with
          Nothing -> j - 1
        | x ->
            let rec same_value j =
              if j < 0 then 0
              else if line.(j).elem = x then same_value (j - 1)
              else j + 1
            in
            same_value (j - 2)
      in
      let jj1 = ini_jj1 in
      let jj2 = j - 1 in
      let jj3 = j in
      let jj4 =
        match line.(j).elem with
          Nothing -> j
        | x ->
            let rec same_value j =
              if j >= Array.length line then j - 1
              else if line.(j).elem = x then same_value (j + 1)
              else j - 1
            in
            same_value (j + 1)
      in
      let (ii, jj1, jj2, jj3, jj4) =
        find_block_with_parents t i jj1 jj2 jj3 jj4
      in
      if jj4 < j2 && jj2 < jj3 then
        begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj4 + 1) end
      else if jj4 < j2 && jj1 = ini_jj1 && jj2 <= jj4 then
        begin mirror_block t ii i jj1 jj4; loop (jj4 + 1) end
      else j - 1
  in
  loop (j1 + 1)

let push_to_left t i j1 j2 =
  let line = t.(i) in
  let rec loop j =
    if j = j1 then j + 1
    else
      let jj1 =
        match line.(j).elem with
          Nothing -> j
        | x ->
            let rec same_value j =
              if j < 0 then 0
              else if line.(j).elem = x then same_value (j - 1)
              else j + 1
            in
            same_value (j - 1)
      in
      let jj2 = j in
      let jj3 = j + 1 in
      let ini_jj4 =
        match line.(j + 1).elem with
          Nothing -> j + 1
        | x ->
            let rec same_value j =
              if j >= Array.length line then j - 1
              else if line.(j).elem = x then same_value (j + 1)
              else j - 1
            in
            same_value (j + 2)
      in
      let jj4 = ini_jj4 in
      let (ii, jj1, jj2, jj3, jj4) =
        find_block_with_parents t i jj1 jj2 jj3 jj4
      in
      if jj1 > j1 && jj2 < jj3 then
        begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj1 - 1) end
      else if jj1 > j1 && jj4 = ini_jj4 && jj3 >= jj1 then
        begin mirror_block t ii i jj1 jj4; loop (jj1 - 1) end
      else j + 1
  in
  loop (j2 - 1)

let fill_gap t i j1 j2 =
  let t1 =
    let t1 = Array.copy t.table in
    for i = 0 to Array.length t.table - 1 do
      t1.(i) <- Array.copy t.table.(i);
      for j = 0 to Array.length t1.(i) - 1 do
        t1.(i).(j) <- copy_data t.table.(i).(j)
      done
    done;
    t1
  in
  let j2 = push_to_left t1 i j1 j2 in
  let j1 = push_to_right t1 i j1 j2 in
  if j1 = j2 - 1 then
    let line = t1.(i - 1) in
    let x = line.(j1).span in
    let y = line.(j2).span in
    let rec loop y j =
      if j >= Array.length line then ()
      else if line.(j).span = y || t1.(i).(j).elem = t1.(i).(j - 1).elem then
        let y = line.(j).span in
        line.(j).span <- x;
        if i > 0 then t1.(i - 1).(j).span <- t1.(i - 1).(j - 1).span;
        loop y (j + 1)
    in
    loop y j2; Some ({table = t1}, true)
  else None

let treat_gaps t =
  let i = Array.length t.table - 1 in
  let rec loop t j =
    let line = t.table.(i) in
    if j = Array.length line then t
    else
      match line.(j).elem with
        Elem _ as y ->
          if y = line.(j - 1).elem then loop t (j + 1)
          else
            let rec loop1 t j1 =
              if j1 < 0 then loop t (j + 1)
              else if y = line.(j1).elem then
                match fill_gap t i j1 j with
                  Some (t, ok) -> if ok then loop t 2 else loop t (j + 1)
                | None -> loop t (j + 1)
              else loop1 t (j1 - 1)
            in
            loop1 t (j - 2)
      | _ -> loop t (j + 1)
  in
  if Array.length t.table.(i) = 1 then t else loop t 2

let group_span_last_row t =
  let row = t.table.(Array.length t.table - 1) in
  let rec loop i =
    if i >= Array.length row then ()
    else
      begin
        begin match row.(i).elem with
          Elem _ | Ghost _ as x ->
            if x = row.(i - 1).elem then row.(i).span <- row.(i - 1).span
        | _ -> ()
        end;
        loop (i + 1)
      end
  in
  loop 1

let has_phony_children phony d t =
  let line = t.table.(Array.length t.table - 1) in
  let rec loop j =
    if j = Array.length line then false
    else
      match line.(j).elem with
        Elem x -> if phony d.dag.(int_of_idag x) then true else loop (j + 1)
      | _ -> loop (j + 1)
  in
  loop 0

let tablify phony no_optim no_group d =
  let a = ancestors d in
  let r = group_by_common_children d a in
  let t = {table = [| Array.of_list r |]} in
  let rec loop t =
    let (t, new_row) = treat_new_row d t in
    if List.for_all (fun x -> x.elem = Nothing) new_row then t
    else
      let t = {table = Array.append t.table [| Array.of_list new_row |]} in
      let t =
        if no_group && not (has_phony_children phony d t) then t
        else begin
          if no_optim then () else equilibrate t;
          group_elem t;
          group_ghost t;
          group_children t;
          group_span_by_common_children d t;
          let t = if no_optim then t else treat_gaps t in
          group_span_last_row t;
          t
        end
      in
      loop t
  in
  loop t

let fall t =
  for i = 1 to Array.length t.table - 1 do
    let line = t.table.(i) in
    let rec loop j =
      if j = Array.length line then ()
      else
        match line.(j).elem with
          Ghost x ->
            let j2 =
              let rec loop j =
                if j = Array.length line then j - 1
                else
                  match line.(j).elem with
                    Ghost y when y = x -> loop (j + 1)
                  | _ -> j - 1
              in
              loop (j + 1)
            in
            let i1 =
              let rec loop i =
                if i < 0 then i + 1
                else
                  let line = t.table.(i) in
                  if (j = 0 || line.(j - 1).span <> line.(j).span) &&
                     (j2 = Array.length line - 1 ||
                      line.(j2 + 1).span <> line.(j2).span) then
                    loop (i - 1)
                  else i + 1
              in
              loop (i - 1)
            in
            let i1 =
              if i1 = i then i1
              else if i1 = 0 then i1
              else if t.table.(i1).(j).elem = Nothing then i1
              else i
            in
            if i1 < i then
              begin
                for k = i downto i1 + 1 do
                  for j = j to j2 do
                    t.table.(k).(j).elem <- t.table.(k - 1).(j).elem;
                    if k < i then
                      t.table.(k).(j).span <- t.table.(k - 1).(j).span
                  done
                done;
                for l = j to j2 do
                  if i1 = 0 || t.table.(i1 - 1).(l).elem = Nothing then
                    t.table.(i1).(l).elem <- Nothing
                  else
                    t.table.(i1).(l) <-
                      if l = j ||
                         t.table.(i1 - 1).(l - 1).span <>
                           t.table.(i1 - 1).(l).span then
                        {elem = Ghost (new_ghost_id ());
                         span = new_span_id ()}
                      else copy_data t.table.(i1).(l - 1)
                done
              end;
            loop (j2 + 1)
        | _ -> loop (j + 1)
    in
    loop 0
  done

let fall2_cool_right t i1 i2 _i3 j1 j2 =
  let span = t.table.(i2 - 1).(j1).span in
  for i = i2 - 1 downto 0 do
    for j = j1 to j2 - 1 do
      t.table.(i).(j) <-
        if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
        else {elem = Nothing; span = new_span_id ()}
    done
  done;
  for i = Array.length t.table - 1 downto 0 do
    for j = j2 to Array.length t.table.(i) - 1 do
      t.table.(i).(j) <-
        if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
        else {elem = Nothing; span = new_span_id ()}
    done
  done;
  let old_span = t.table.(i2 - 1).(j1).span in
  let rec loop j =
    if j = Array.length t.table.(i2 - 1) then ()
    else if t.table.(i2 - 1).(j).span = old_span then
      begin t.table.(i2 - 1).(j).span <- span; loop (j + 1) end
  in
  loop j1

let fall2_cool_left t i1 i2 _i3 j1 j2 =
  let span = t.table.(i2 - 1).(j2).span in
  for i = i2 - 1 downto 0 do
    for j = j1 + 1 to j2 do
      t.table.(i).(j) <-
        if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
        else {elem = Nothing; span = new_span_id ()}
    done
  done;
  for i = Array.length t.table - 1 downto 0 do
    for j = j1 downto 0 do
      t.table.(i).(j) <-
        if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
        else {elem = Nothing; span = new_span_id ()}
    done
  done;
  let old_span = t.table.(i2 - 1).(j2).span in
  let rec loop j =
    if j < 0 then ()
    else if t.table.(i2 - 1).(j).span = old_span then
      begin t.table.(i2 - 1).(j).span <- span; loop (j - 1) end
  in
  loop j2

let do_fall2_right t i1 i2 j1 j2 =
  let i3 =
    let rec loop_i i =
      if i < 0 then 0
      else
        let rec loop_j j =
          if j = Array.length t.table.(i) then loop_i (i - 1)
          else
            match t.table.(i).(j).elem with
              Nothing -> loop_j (j + 1)
            | _ -> i + 1
        in
        loop_j j2
    in
    loop_i (Array.length t.table - 1)
  in
  let new_height = i3 + i2 - i1 in
  let t =
    if new_height > Array.length t.table then
      let rec loop cnt t =
        if cnt = 0 then t
        else
          let new_line =
            Array.init (Array.length t.table.(0))
              (fun _ -> {elem = Nothing; span = new_span_id ()})
          in
          let t = {table = Array.append t.table [| new_line |]} in
          loop (cnt - 1) t
      in
      loop (new_height - Array.length t.table) t
    else t
  in
  fall2_cool_right t i1 i2 i3 j1 j2; t

let do_fall2_left t i1 i2 j1 j2 =
  let i3 =
    let rec loop_i i =
      if i < 0 then 0
      else
        let rec loop_j j =
          if j < 0 then loop_i (i - 1)
          else
            match t.table.(i).(j).elem with
              Nothing -> loop_j (j - 1)
            | _ -> i + 1
        in
        loop_j j1
    in
    loop_i (Array.length t.table - 1)
  in
  let new_height = i3 + i2 - i1 in
  let t =
    if new_height > Array.length t.table then
      let rec loop cnt t =
        if cnt = 0 then t
        else
          let new_line =
            Array.init (Array.length t.table.(0))
              (fun _ -> {elem = Nothing; span = new_span_id ()})
          in
          let t = {table = Array.append t.table [| new_line |]} in
          loop (cnt - 1) t
      in
      loop (new_height - Array.length t.table) t
    else t
  in
  fall2_cool_left t i1 i2 i3 j1 j2; t

let do_shorten_too_long t i1 j1 j2 =
  for i = i1 to Array.length t.table - 2 do
    for j = j1 to j2 - 1 do t.table.(i).(j) <- t.table.(i + 1).(j) done
  done;
  let i = Array.length t.table - 1 in
  for j = j1 to j2 - 1 do
    t.table.(i).(j) <- {elem = Nothing; span = new_span_id ()}
  done;
  t
;;

let try_fall2_right t i j =
  match t.table.(i).(j).elem with
    Ghost _ ->
      let i1 =
        let rec loop i =
          if i < 0 then 0
          else
            match t.table.(i).(j).elem with
              Ghost _ -> loop (i - 1)
            | _ -> i + 1
        in
        loop (i - 1)
      in
      let separated1 =
        let rec loop i =
          if i < 0 then true
          else if
            j > 0 && t.table.(i).(j - 1).span = t.table.(i).(j).span then
            false
          else loop (i - 1)
        in
        loop (i1 - 1)
      in
      let j2 =
        let x = t.table.(i).(j).span in
        let rec loop j2 =
          if j2 = Array.length t.table.(i) then j2
          else
            match t.table.(i).(j2) with
              {elem = Ghost _; span = y} when y = x -> loop (j2 + 1)
            | _ -> j2
        in
        loop (j + 1)
      in
      let separated2 =
        let rec loop i =
          if i = Array.length t.table then true
          else if j2 = Array.length t.table.(i) then false
          else if t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then false
          else loop (i + 1)
        in
        loop (i + 1)
      in
      if not separated1 || not separated2 then None
      else Some (do_fall2_right t i1 (i + 1) j j2)
  | _ -> None

let try_fall2_left t i j =
  match t.table.(i).(j).elem with
    Ghost _ ->
      let i1 =
        let rec loop i =
          if i < 0 then 0
          else
            match t.table.(i).(j).elem with
              Ghost _ -> loop (i - 1)
            | _ -> i + 1
        in
        loop (i - 1)
      in
      let separated1 =
        let rec loop i =
          if i < 0 then true
          else if
            j < Array.length t.table.(i) - 1 &&
            t.table.(i).(j).span = t.table.(i).(j + 1).span then
            false
          else loop (i - 1)
        in
        loop (i1 - 1)
      in
      let j1 =
        let x = t.table.(i).(j).span in
        let rec loop j1 =
          if j1 < 0 then j1
          else
            match t.table.(i).(j1) with
              {elem = Ghost _; span = y} when y = x -> loop (j1 - 1)
            | _ -> j1
        in
        loop (j - 1)
      in
      let separated2 =
        let rec loop i =
          if i = Array.length t.table then true
          else if j1 < 0 then false
          else if t.table.(i).(j1).span = t.table.(i).(j1 + 1).span then false
          else loop (i + 1)
        in
        loop (i + 1)
      in
      if not separated1 || not separated2 then None
      else Some (do_fall2_left t i1 (i + 1) j1 j)
  | _ -> None

let try_shorten_too_long t i j =
  match t.table.(i).(j).elem with
    Ghost _ ->
      let j2 =
        let x = t.table.(i).(j).span in
        let rec loop j2 =
          if j2 = Array.length t.table.(i) then j2
          else
            match t.table.(i).(j2) with
              {elem = Ghost _; span = y} when y = x -> loop (j2 + 1)
            | _ -> j2
        in
        loop (j + 1)
      in
      let i1 =
        let rec loop i =
          if i = Array.length t.table then i
          else
            match t.table.(i).(j).elem with
              Elem _ -> loop (i + 1)
            | _ -> i
        in
        loop (i + 1)
      in
      let i2 =
        let rec loop i =
          if i = Array.length t.table then i
          else
            match t.table.(i).(j).elem with
              Nothing -> loop (i + 1)
            | _ -> i
        in
        loop i1
      in
      let separated_left =
        let rec loop i =
          if i = i2 then true
          else if
            j > 0 && t.table.(i).(j).span = t.table.(i).(j - 1).span then
            false
          else loop (i + 1)
        in
        loop i
      in
      let separated_right =
        let rec loop i =
          if i = i2 then true
          else if
            j2 < Array.length t.table.(i) &&
            t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then
            false
          else loop (i + 1)
        in
        loop i
      in
      if not separated_left || not separated_right then None
      else if i2 < Array.length t.table then None
      else Some (do_shorten_too_long t i j j2)
  | _ -> None

let fall2_right t =
  let rec loop_i i t =
    if i <= 0 then t
    else
      let rec loop_j j t =
        if j < 0 then loop_i (i - 1) t
        else
          match try_fall2_right t i j with
            Some t -> loop_i (Array.length t.table - 1) t
          | None -> loop_j (j - 1) t
      in
      loop_j (Array.length t.table.(i) - 2) t
  in
  loop_i (Array.length t.table - 1) t

let fall2_left t =
  let rec loop_i i t =
    if i <= 0 then t
    else
      let rec loop_j j t =
        if j >= Array.length t.table.(i) then loop_i (i - 1) t
        else
          match try_fall2_left t i j with
            Some t -> loop_i (Array.length t.table - 1) t
          | None -> loop_j (j + 1) t
      in
      loop_j 1 t
  in
  loop_i (Array.length t.table - 1) t

let shorten_too_long t =
  let rec loop_i i t =
    if i <= 0 then t
    else
      let rec loop_j j t =
        if j >= Array.length t.table.(i) then loop_i (i - 1) t
        else
          match try_shorten_too_long t i j with
            Some t -> loop_i (Array.length t.table - 1) t
          | None -> loop_j (j + 1) t
      in
      loop_j 1 t
  in
  loop_i (Array.length t.table - 1) t

(* top_adjust:
   deletes all empty rows that might have appeared on top of the table
   after the falls *)

let top_adjust t =
  let di =
    let rec loop i =
      if i = Array.length t.table then i
      else
        let rec loop_j j =
          if j = Array.length t.table.(i) then loop (i + 1)
          else if t.table.(i).(j).elem <> Nothing then i
          else loop_j (j + 1)
        in
        loop_j 0
    in
    loop 0
  in
  if di > 0 then
    begin
      for i = 0 to Array.length t.table - 1 - di do
        t.table.(i) <- t.table.(i + di)
      done;
      {table = Array.sub t.table 0 (Array.length t.table - di)}
    end
  else t

(* bottom_adjust:
   deletes all empty rows that might have appeared on bottom of the table
   after the falls *)

let bottom_adjust t =
  let last_i =
    let rec loop i =
      if i < 0 then i
      else
        let rec loop_j j =
          if j = Array.length t.table.(i) then loop (i - 1)
          else if t.table.(i).(j).elem <> Nothing then i
          else loop_j (j + 1)
        in
        loop_j 0
    in
    loop (Array.length t.table - 1)
  in
  if last_i < Array.length t.table - 1 then
    {table = Array.sub t.table 0 (last_i + 1)}
  else t

(* invert *)

let invert_dag d =
  let d = {dag = Array.copy d.dag} in
  for i = 0 to Array.length d.dag - 1 do
    let n = d.dag.(i) in
    d.dag.(i) <-
      {pare = List.map (fun x -> x) n.chil; valu = n.valu;
       chil = List.map (fun x -> x) n.pare}
  done;
  d

let invert_table t =
  let t' = {table = Array.copy t.table} in
  let len = Array.length t.table in
  for i = 0 to len - 1 do
    t'.table.(i) <-
      Array.init (Array.length t.table.(0))
        (fun j ->
           let d = t.table.(len - 1 - i).(j) in
           {elem = d.elem; span = d.span});
    if i < len - 1 then
      for j = 0 to Array.length t'.table.(i) - 1 do
        t'.table.(i).(j).span <- t.table.(len - 2 - i).(j).span
      done
  done;
  t'

(* main *)

let table_of_dag phony no_optim invert no_group d =
  let d = if invert then invert_dag d else d in
  let t = tablify phony no_optim no_group d in
  let t = if invert then invert_table t else t in
  fall t;
  let t = fall2_right t in
  let t = fall2_left t in
  let t = shorten_too_long t in
  let t = top_adjust t in let t = bottom_adjust t in t


(* input dag *)

let phony _ = false
let indi_txt n = n.valu

let string_table border hts =
  let buf = Buffer.create 30 in
  Printf.bprintf buf "<center><table border=%d" border;
  Printf.bprintf buf " cellspacing=0 cellpadding=0>\n";
  for i = 0 to Array.length hts - 1 do
    Printf.bprintf buf  "<tr>\n";
    for j = 0 to Array.length hts.(i) - 1 do
      let (colspan, align, td) = hts.(i).(j) in
      Printf.bprintf buf "<td";
      if colspan = 1 && (td = TDstring "&nbsp;" || td = TDhr CenterA) then ()
      else Printf.bprintf buf " colspan=%d" colspan;
      begin match align, td with
        LeftA, TDhr LeftA -> Printf.bprintf buf " align=left"
      | LeftA, _ -> ()
      | CenterA, _ -> Printf.bprintf buf " align=center"
      | RightA, _ -> Printf.bprintf buf " align=right"
      end;
      Printf.bprintf buf ">";
      begin match td with
        TDstring s -> Printf.bprintf buf "%s" s
      | TDhr align ->
          Printf.bprintf buf "<hr noshade size=1";
          begin match align with
            LeftA -> Printf.bprintf buf " width=\"50%%\" align=left"
          | RightA -> Printf.bprintf buf " width=\"50%%\" align=right"
          | _ -> ()
          end;
          Printf.bprintf buf ">";
          ()
      end;
      Printf.bprintf buf "</td>\n";
      ()
    done
  done;
  Printf.bprintf buf "</table></center>\n";
  Buffer.contents buf

let invert = ref false
let border = ref 0
let no_optim = ref false
let no_group = ref false

let html_of_dag d =
  let t = table_of_dag phony !no_optim !invert !no_group d in
  let hts = html_table_struct indi_txt phony d t in
  string_table !border hts


(********************************* Max's code **********************************)
(** This function takes a list of classes and a list of class types
   and create the associate dag. *)
let create_class_dag cl_list clt_list =
  let module M = Odoc_info.Class in
  (* the list of all the classes concerned *)
  let cl_list2 = List.map (fun c -> (c.M.cl_name, Some (M.Cl c))) cl_list in
  let clt_list2 = List.map (fun ct -> (ct.M.clt_name, Some (M.Cltype (ct, [])))) clt_list in
  let list = cl_list2 @ clt_list2 in
  let all_classes =
    let rec iter list2 =
      List.fold_left
        (fun acc -> fun (name, cct_opt) ->
          let l =
            match cct_opt with
              None -> []
            | Some (M.Cl c) ->
                iter
                  (List.map
                     (fun inh ->(inh.M.ic_name, inh.M.ic_class))
                     (match c.M.cl_kind with
                       M.Class_structure (inher_l, _) ->
                         inher_l
                     | _ ->
                         []
                     )
                  )
            | Some (M.Cltype (ct, _)) ->
                iter
                  (List.map
                     (fun inh ->(inh.M.ic_name, inh.M.ic_class))
                     (match ct.M.clt_kind with
                       M.Class_signature (inher_l, _) ->
                         inher_l
                     | _ ->
                         []
                     )
                  )
          in
          (name, cct_opt) :: (acc @ l)
        )
        []
        list2
    in
    iter list
  in
  let rec distinct acc = function
    [] ->
      acc
    |   (name, cct_opt) :: q ->
        if List.exists (fun (name2, _) -> name = name2) acc then
          distinct acc q
        else
          distinct ((name, cct_opt) :: acc) q
  in
  let distinct_classes = distinct [] all_classes in
  let liste_index =
    let rec f n = function
        [] -> []
      | (name, _) :: q -> (name, n) :: (f (n+1) q)
    in
    f 0 distinct_classes
  in
  let array1 = Array.of_list distinct_classes in
  (* create the dag array, filling parents and values *)
  let fmap (name, cct_opt) =
    { pare = List.map
        (fun inh -> List.assoc inh.M.ic_name liste_index )
        (match cct_opt with
          None -> []
        | Some (M.Cl c) ->
            (match c.M.cl_kind with
              M.Class_structure (inher_l, _) ->
                inher_l
            | _ ->
                []
            )
        | Some (M.Cltype (ct, _)) ->
            (match ct.M.clt_kind with
              M.Class_signature (inher_l, _) ->
                inher_l
            | _ ->
                []
            )
        );
      valu = (name, cct_opt) ;
      chil = []
    }
  in
  let dag = { dag = Array.map fmap array1 } in
  (* fill the children *)
  let fiter i node =
    let l = Array.to_list dag.dag in
    let l2 = List.map (fun n -> n.valu)
        (List.filter (fun n -> List.mem i n.pare) l)
    in
    node.chil <- List.map (fun (name,_) -> List.assoc name liste_index) l2
  in
  Array.iteri fiter dag.dag;
  dag