ocamldoc/odoc_dag2html.ml

   1 (***********************************************************************)
   2 (*                             OCamldoc                                *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13
  14 (** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *)
  15
  16 type 'a dag = { mutable dag : 'a node array }
  17 and 'a node =
  18   { mutable pare : idag list; valu : 'a; mutable chil : idag list }
  19 and idag = int
  20 ;;
  21
  22 external int_of_idag : idag -> int = "%identity";;
  23 external idag_of_int : int -> idag = "%identity";;
  24
  25 type 'a table = { mutable table : 'a data array array }
  26 and 'a data = { mutable elem : 'a elem; mutable span : span_id }
  27 and 'a elem = Elem of 'a | Ghost of ghost_id | Nothing
  28 and span_id
  29 and ghost_id
  30 ;;
  31
  32 external span_id_of_int : int -> span_id = "%identity";;
  33 external int_of_span_id : span_id -> int = "%identity";;
  34 external ghost_id_of_int : int -> ghost_id = "%identity";;
  35 external int_of_ghost_id : ghost_id -> int = "%identity";;
  36
  37 let new_span_id = let i = ref 0 in fun () -> incr i; span_id_of_int !i;;
  38
  39 let new_ghost_id = let i = ref 0 in fun () -> incr i; ghost_id_of_int !i;;
  40
  41 (** creating the html table structure *)
  42
  43 type align = LeftA | CenterA | RightA;;
  44 type table_data = TDstring of string | TDhr of align;;
  45 type html_table = (int * align * table_data) array array;;
  46
  47 let html_table_struct indi_txt phony d t =
  48   let phony =
  49     function
  50       Elem e -> phony d.dag.(int_of_idag e)
  51     | Ghost _ -> false
  52     | Nothing -> true
  53   in
  54   let elem_txt =
  55     function
  56       Elem e -> indi_txt d.dag.(int_of_idag e)
  57     | Ghost _ -> "|"
  58     | Nothing -> "&nbsp;"
  59   in
  60   let bar_txt =
  61     function
  62       Elem _ | Ghost _ -> "|"
  63     | Nothing -> "&nbsp;"
  64   in
  65   let all_empty i =
  66     let rec loop j =
  67       if j = Array.length t.table.(i) then true
  68       else
  69         match t.table.(i).(j).elem with
  70           Nothing -> loop (j + 1)
  71         | e -> if phony e then loop (j + 1) else false
  72     in
  73     loop 0
  74   in
  75   let line_elem_txt i =
  76     let les =
  77       let rec loop les j =
  78         if j = Array.length t.table.(i) then les
  79         else
  80           let x = t.table.(i).(j) in
  81           let next_j =
  82             let rec loop j =
  83               if j = Array.length t.table.(i) then j
  84               else if t.table.(i).(j) = x then loop (j + 1)
  85               else j
  86             in
  87             loop (j + 1)
  88           in
  89           let colspan = 3 * (next_j - j) in
  90           let les = (1, LeftA, TDstring "&nbsp;") :: les in
  91           let les =
  92             let s =
  93               if t.table.(i).(j).elem = Nothing then "&nbsp;"
  94               else elem_txt t.table.(i).(j).elem
  95             in
  96             (colspan - 2, CenterA, TDstring s) :: les
  97           in
  98           let les = (1, LeftA, TDstring "&nbsp;") :: les in loop les next_j
  99       in
 100       loop [] 0
 101     in
 102     Array.of_list (List.rev les)
 103   in
 104   let vbars_txt k i =
 105     let les =
 106       let rec loop les j =
 107         if j = Array.length t.table.(i) then les
 108         else
 109           let x = t.table.(i).(j) in
 110           let next_j =
 111             let rec loop j =
 112               if j = Array.length t.table.(i) then j
 113               else if t.table.(i).(j) = x then loop (j + 1)
 114               else j
 115             in
 116             loop (j + 1)
 117           in
 118           let colspan = 3 * (next_j - j) in
 119           let les = (1, LeftA, TDstring "&nbsp;") :: les in
 120           let les =
 121             let s =
 122               if k > 0 && t.table.(k - 1).(j).elem = Nothing ||
 123                  t.table.(k).(j).elem = Nothing then
 124                 "&nbsp;"
 125               else if phony t.table.(i).(j).elem then "&nbsp;"
 126               else bar_txt t.table.(i).(j).elem
 127             in
 128             (colspan - 2, CenterA, TDstring s) :: les
 129           in
 130           let les = (1, LeftA, TDstring "&nbsp;") :: les in loop les next_j
 131       in
 132       loop [] 0
 133     in
 134     Array.of_list (List.rev les)
 135   in
 136   let alone_bar_txt i =
 137     let les =
 138       let rec loop les j =
 139         if j = Array.length t.table.(i) then les
 140         else
 141           let next_j =
 142             let x = t.table.(i).(j).span in
 143             let rec loop j =
 144               if j = Array.length t.table.(i) then j
 145               else if t.table.(i).(j).span = x then loop (j + 1)
 146               else j
 147             in
 148             loop (j + 1)
 149           in
 150           let colspan = 3 * (next_j - j) - 2 in
 151           let les = (1, LeftA, TDstring "&nbsp;") :: les in
 152           let les =
 153             if t.table.(i).(j).elem = Nothing ||
 154                t.table.(i + 1).(j).elem = Nothing then
 155               (colspan, LeftA, TDstring "&nbsp;") :: les
 156             else
 157               let s =
 158                 let all_ph =
 159                   let rec loop j =
 160                     if j = next_j then true
 161                     else if phony t.table.(i + 1).(j).elem then loop (j + 1)
 162                     else false
 163                   in
 164                   loop j
 165                 in
 166                 if all_ph then "&nbsp;" else "|"
 167               in
 168               (colspan, CenterA, TDstring s) :: les
 169           in
 170           let les = (1, LeftA, TDstring "&nbsp;") :: les in loop les next_j
 171       in
 172       loop [] 0
 173     in
 174     Array.of_list (List.rev les)
 175   in
 176   let exist_several_branches i k =
 177     let rec loop j =
 178       if j = Array.length t.table.(i) then false
 179       else
 180         let x = t.table.(i).(j).span in
 181         let e = t.table.(k).(j).elem in
 182         let rec loop1 j =
 183           if j = Array.length t.table.(i) then false
 184           else if t.table.(i).(j).elem = Nothing then loop j
 185           else if t.table.(i).(j).span <> x then loop j
 186           else if t.table.(k).(j).elem <> e then true
 187           else loop1 (j + 1)
 188         in
 189         loop1 (j + 1)
 190     in
 191     loop 0
 192   in
 193   let hbars_txt i k =
 194     let les =
 195       let rec loop les j =
 196         if j = Array.length t.table.(i) then les
 197         else
 198           let next_j =
 199             let e = t.table.(i).(j).elem in
 200             let x = t.table.(i).(j).span in
 201             let rec loop j =
 202               if j = Array.length t.table.(i) then j
 203               else if e = Nothing && t.table.(i).(j).elem = Nothing then
 204                 loop (j + 1)
 205               else if t.table.(i).(j).span = x then loop (j + 1)
 206               else j
 207             in
 208             loop (j + 1)
 209           in
 210           let rec loop1 les l =
 211             if l = next_j then loop les next_j
 212             else
 213               let next_l =
 214                 let y = t.table.(k).(l) in
 215                 match y.elem with
 216                   Elem _ | Ghost _ ->
 217                     let rec loop l =
 218                       if l = Array.length t.table.(i) then l
 219                       else if t.table.(k).(l) = y then loop (l + 1)
 220                       else l
 221                     in
 222                     loop (l + 1)
 223                 | _ -> l + 1
 224               in
 225               if next_l > next_j then
 226                 begin
 227                   Printf.eprintf
 228                     "assert false i %d k %d l %d next_l %d next_j %d\n" i k l
 229                     next_l next_j;
 230                   flush stderr
 231                 end;
 232               let next_l = min next_l next_j in
 233               let colspan = 3 * (next_l - l) - 2 in
 234               let les =
 235                 match t.table.(i).(l).elem, t.table.(i + 1).(l).elem with
 236                   Nothing, _ | _, Nothing ->
 237                     (colspan + 2, LeftA, TDstring "&nbsp;") :: les
 238                 | _ ->
 239                     let ph s =
 240                       if phony t.table.(k).(l).elem then TDstring "&nbsp;"
 241                       else s
 242                     in
 243                     if l = j && next_l = next_j then
 244                       let les = (1, LeftA, TDstring "&nbsp;") :: les in
 245                       let s = ph (TDstring "|") in
 246                       let les = (colspan, CenterA, s) :: les in
 247                       let les = (1, LeftA, TDstring "&nbsp;") :: les in les
 248                     else if l = j then
 249                       let les = (1, LeftA, TDstring "&nbsp;") :: les in
 250                       let s = ph (TDhr RightA) in
 251                       let les = (colspan, RightA, s) :: les in
 252                       let s = ph (TDhr CenterA) in
 253                       let les = (1, LeftA, s) :: les in les
 254                     else if next_l = next_j then
 255                       let s = ph (TDhr CenterA) in
 256                       let les = (1, LeftA, s) :: les in
 257                       let s = ph (TDhr LeftA) in
 258                       let les = (colspan, LeftA, s) :: les in
 259                       let les = (1, LeftA, TDstring "&nbsp;") :: les in les
 260                     else
 261                       let s = ph (TDhr CenterA) in
 262                       (colspan + 2, LeftA, s) :: les
 263               in
 264               loop1 les next_l
 265           in
 266           loop1 les j
 267       in
 268       loop [] 0
 269     in
 270     Array.of_list (List.rev les)
 271   in
 272   let hts =
 273     let rec loop hts i =
 274       if i = Array.length t.table then hts
 275       else if i = Array.length t.table - 1 && all_empty i then hts
 276       else
 277         let hts = line_elem_txt i :: hts in
 278         let hts =
 279           if i < Array.length t.table - 1 then
 280             let hts = vbars_txt (i + 1) i :: hts in
 281             let hts =
 282               if exist_several_branches i i then
 283                 alone_bar_txt i :: hbars_txt i i :: hts
 284               else hts
 285             in
 286             let hts =
 287               if exist_several_branches i (i + 1) &&
 288                  (i < Array.length t.table - 2 ||
 289                   not (all_empty (i + 1))) then
 290                 vbars_txt (i + 1) (i + 1) :: hbars_txt i (i + 1) :: hts
 291               else hts
 292             in
 293             hts
 294           else hts
 295         in
 296         loop hts (i + 1)
 297     in
 298     loop [] 0
 299   in
 300   Array.of_list (List.rev hts)
 301 ;;
 302
 303 (** transforming dag into table *)
 304
 305 let ancestors d =
 306   let rec loop i =
 307     if i = Array.length d.dag then []
 308     else
 309       let n = d.dag.(i) in
 310       if n.pare = [] then idag_of_int i :: loop (i + 1) else loop (i + 1)
 311   in
 312   loop 0
 313 ;;
 314
 315 let get_children d parents =
 316   let rec merge_children children el =
 317     List.fold_right
 318       (fun (x, _) children ->
 319          match x with
 320            Elem e ->
 321              let e = d.dag.(int_of_idag e) in
 322              List.fold_right
 323                (fun c children ->
 324                   if List.mem c children then children else c :: children)
 325                e.chil children
 326          | _ -> [])
 327       el children
 328   in
 329   merge_children [] parents
 330 ;;
 331
 332 let rec get_block t i j =
 333   if j = Array.length t.table.(i) then None
 334   else if j = Array.length t.table.(i) - 1 then
 335     let x = t.table.(i).(j) in Some ([x.elem, 1], 1, x.span)
 336   else
 337     let x = t.table.(i).(j) in
 338     let y = t.table.(i).(j + 1) in
 339     if y.span = x.span then
 340       match get_block t i (j + 1) with
 341         Some ((x1, c1) :: list, mpc, span) ->
 342           let (list, mpc) =
 343             if x1 = x.elem then (x1, c1 + 1) :: list, max mpc (c1 + 1)
 344             else (x.elem, 1) :: (x1, c1) :: list, max mpc c1
 345           in
 346           Some (list, mpc, span)
 347       | _ -> assert false
 348     else Some ([x.elem, 1], 1, x.span)
 349 ;;
 350
 351 let group_by_common_children d list =
 352   let module O = struct type t = idag;; let compare = compare;; end
 353   in
 354   let module S = Set.Make (O)
 355   in
 356   let nlcsl =
 357     List.map
 358       (fun id ->
 359          let n = d.dag.(int_of_idag id) in
 360          let cs = List.fold_right S.add n.chil S.empty in [id], cs)
 361       list
 362   in
 363   let nlcsl =
 364     let rec loop =
 365       function
 366         [] -> []
 367       | (nl, cs) :: rest ->
 368           let rec loop1 beg =
 369             function
 370               (nl1, cs1) :: rest1 ->
 371                 if S.is_empty (S.inter cs cs1) then
 372                   loop1 ((nl1, cs1) :: beg) rest1
 373                 else
 374                   loop ((nl @ nl1, S.union cs cs1) :: (List.rev beg @ rest1))
 375             | [] -> (nl, cs) :: loop rest
 376           in
 377           loop1 [] rest
 378     in
 379     loop nlcsl
 380   in
 381   List.fold_right
 382     (fun (nl, _) a ->
 383        let span = new_span_id () in
 384        List.fold_right (fun n a -> {elem = Elem n; span = span} :: a) nl a)
 385     nlcsl []
 386 ;;
 387
 388 let copy_data d = {elem = d.elem; span = d.span};;
 389
 390 let insert_columns t nb j =
 391   let t1 = Array.create (Array.length t.table) [| |] in
 392   for i = 0 to Array.length t.table - 1 do
 393     let line = t.table.(i) in
 394     let line1 = Array.create (Array.length line + nb) line.(0) in
 395     t1.(i) <- line1;
 396     let rec loop k =
 397       if k = Array.length line then ()
 398       else
 399         begin
 400           if k < j then line1.(k) <- copy_data line.(k)
 401           else if k = j then
 402             for r = 0 to nb do line1.(k + r) <- copy_data line.(k) done
 403           else line1.(k + nb) <- copy_data line.(k);
 404           loop (k + 1)
 405         end
 406     in
 407     loop 0
 408   done;
 409   {table = t1}
 410 ;;
 411
 412 let rec gcd a b =
 413   if a < b then gcd b a else if b = 0 then a else gcd b (a mod b)
 414 ;;
 415
 416 let treat_new_row d t =
 417   let i = Array.length t.table - 1 in
 418   let rec loop t i j =
 419     match get_block t i j with
 420       Some (parents, max_parent_colspan, span) ->
 421         let children = get_children d parents in
 422         let children =
 423           if children = [] then [{elem = Nothing; span = new_span_id ()}]
 424           else
 425             List.map (fun n -> {elem = Elem n; span = new_span_id ()})
 426               children
 427         in
 428         let simple_parents_colspan =
 429           List.fold_left (fun x (_, c) -> x + c) 0 parents
 430         in
 431         if simple_parents_colspan mod List.length children = 0 then
 432           let j = j + simple_parents_colspan in
 433           let children =
 434             let cnt = simple_parents_colspan / List.length children in
 435             List.fold_right
 436               (fun d list ->
 437                  let rec loop cnt list =
 438                    if cnt = 1 then d :: list
 439                    else copy_data d :: loop (cnt - 1) list
 440                  in
 441                  loop cnt list)
 442               children []
 443           in
 444           let (t, children_rest) = loop t i j in t, children @ children_rest
 445         else
 446           let parent_colspan =
 447             List.fold_left
 448               (fun scm (_, c) -> let g = gcd scm c in scm / g * c)
 449               max_parent_colspan parents
 450           in
 451           let (t, parents, _) =
 452             List.fold_left
 453               (fun (t, parents, j) (x, c) ->
 454                  let to_add = parent_colspan / c - 1 in
 455                  let t =
 456                    let rec loop cc t j =
 457                      if cc = 0 then t
 458                      else
 459                        let t = insert_columns t to_add j in
 460                        loop (cc - 1) t (j + to_add + 1)
 461                    in
 462                    loop c t j
 463                  in
 464                  t, (x, parent_colspan) :: parents, j + parent_colspan)
 465               (t, [], j) parents
 466           in
 467           let parents = List.rev parents in
 468           let parents_colspan = parent_colspan * List.length parents in
 469           let children_colspan = List.length children in
 470           let g = gcd parents_colspan children_colspan in
 471           let (t, j) =
 472             let cnt = children_colspan / g in
 473             List.fold_left
 474               (fun (t, j) (_, c) ->
 475                  let rec loop cc t j =
 476                    if cc = 0 then t, j
 477                    else
 478                      let t = insert_columns t (cnt - 1) j in
 479                      let j = j + cnt in loop (cc - 1) t j
 480                  in
 481                  loop c t j)
 482               (t, j) parents
 483           in
 484           let children =
 485             let cnt = parents_colspan / g in
 486             List.fold_right
 487               (fun d list ->
 488                  let rec loop cnt list =
 489                    if cnt = 0 then list else d :: loop (cnt - 1) list
 490                  in
 491                  loop cnt list)
 492               children []
 493           in
 494           let (t, children_rest) = loop t i j in t, children @ children_rest
 495     | None -> t, []
 496   in
 497   loop t i 0
 498 ;;
 499
 500 let down_it t i k y =
 501   t.table.(Array.length t.table - 1).(k) <- t.table.(i).(k);
 502   for r = i to Array.length t.table - 2 do
 503     t.table.(r).(k) <- {elem = Ghost (new_ghost_id ()); span = new_span_id ()}
 504   done
 505 ;;
 506
 507 (* equilibrate:
 508    in the last line, for all elem A, make fall all As, which are located at
 509    its right side above, to its line,
 510                              A             |
 511    i.e. transform all        . into        |
 512                       A.......      A......A
 513 *)
 514
 515 let equilibrate t =
 516   let ilast = Array.length t.table - 1 in
 517   let last = t.table.(ilast) in
 518   let len = Array.length last in
 519   let rec loop j =
 520     if j = len then ()
 521     else
 522       match last.(j).elem with
 523         Elem x ->
 524           let rec loop1 i =
 525             if i = ilast then loop (j + 1)
 526             else
 527               let rec loop2 k =
 528                 if k = len then loop1 (i + 1)
 529                 else
 530                   match t.table.(i).(k).elem with
 531                     Elem y when x = y -> down_it t i k y; loop 0
 532                   | _ -> loop2 (k + 1)
 533               in
 534               loop2 0
 535           in
 536           loop1 0
 537       | _ -> loop (j + 1)
 538   in
 539   loop 0
 540 ;;
 541
 542 (* group_elem:
 543    transform all x y into x x
 544                  A A      A A *)
 545
 546 let group_elem t =
 547   for i = 0 to Array.length t.table - 2 do
 548     for j = 1 to Array.length t.table.(0) - 1 do
 549       match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with
 550         Elem x, Elem y when x = y ->
 551           t.table.(i).(j).span <- t.table.(i).(j - 1).span
 552       | _ -> ()
 553     done
 554   done
 555 ;;
 556
 557 (* group_ghost:
 558                  x  x       x  x           |a |a      |a |a
 559    transform all |a |b into |a |a and all  x  y  into x  x
 560                  y  z       y  y           A  A       A  A  *)
 561
 562 let group_ghost t =
 563   for i = 0 to Array.length t.table - 2 do
 564     for j = 1 to Array.length t.table.(0) - 1 do
 565       begin match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with
 566         Ghost x, Ghost _ ->
 567           if t.table.(i).(j - 1).span = t.table.(i).(j).span then
 568             t.table.(i + 1).(j) <-
 569               {elem = Ghost x; span = t.table.(i + 1).(j - 1).span}
 570       | _ -> ()
 571       end;
 572       match t.table.(i).(j - 1).elem, t.table.(i).(j).elem with
 573         Ghost x, Ghost _ ->
 574           if t.table.(i + 1).(j - 1).elem = t.table.(i + 1).(j).elem then
 575             begin
 576               t.table.(i).(j) <-
 577                 {elem = Ghost x; span = t.table.(i).(j - 1).span};
 578               if i > 0 then
 579                 t.table.(i - 1).(j).span <- t.table.(i - 1).(j - 1).span
 580             end
 581       | _ -> ()
 582     done
 583   done
 584 ;;
 585
 586 (* group_children:
 587    transform all A A into A A
 588                  x y      x x *)
 589
 590 let group_children t =
 591   for i = 0 to Array.length t.table - 1 do
 592     let line = t.table.(i) in
 593     let len = Array.length line in
 594     for j = 1 to len - 1 do
 595       if line.(j).elem = line.(j - 1).elem && line.(j).elem <> Nothing then
 596         line.(j).span <- line.(j - 1).span
 597     done
 598   done
 599 ;;
 600
 601 (* group_span_by_common_children:
 602    in the last line, transform all
 603      A B into A B
 604      x y      x x
 605    if A and B have common children *)
 606
 607 let group_span_by_common_children d t =
 608   let module O = struct type t = idag;; let compare = compare;; end
 609   in
 610   let module S = Set.Make (O)
 611   in
 612   let i = Array.length t.table - 1 in
 613   let line = t.table.(i) in
 614   let rec loop j cs =
 615     if j = Array.length line then ()
 616     else
 617       match line.(j).elem with
 618         Elem id ->
 619           let n = d.dag.(int_of_idag id) in
 620           let curr_cs = List.fold_right S.add n.chil S.empty in
 621           if S.is_empty (S.inter cs curr_cs) then loop (j + 1) curr_cs
 622           else
 623             begin
 624               line.(j).span <- line.(j - 1).span;
 625               loop (j + 1) (S.union cs curr_cs)
 626             end
 627       | _ -> loop (j + 1) S.empty
 628   in
 629   loop 0 S.empty
 630 ;;
 631
 632 let find_same_parents t i j1 j2 j3 j4 =
 633   let rec loop i j1 j2 j3 j4 =
 634     if i = 0 then i, j1, j2, j3, j4
 635     else
 636       let x1 = t.(i - 1).(j1) in
 637       let x2 = t.(i - 1).(j2) in
 638       let x3 = t.(i - 1).(j3) in
 639       let x4 = t.(i - 1).(j4) in
 640       if x1.span = x4.span then i, j1, j2, j3, j4
 641       else
 642         let j1 =
 643           let rec loop j =
 644             if j < 0 then 0
 645             else if t.(i - 1).(j).span = x1.span then loop (j - 1)
 646             else j + 1
 647           in
 648           loop (j1 - 1)
 649         in
 650         let j2 =
 651           let rec loop j =
 652             if j >= Array.length t.(i) then j - 1
 653             else if t.(i - 1).(j).span = x2.span then loop (j + 1)
 654             else j - 1
 655           in
 656           loop (j2 + 1)
 657         in
 658         let j3 =
 659           let rec loop j =
 660             if j < 0 then 0
 661             else if t.(i - 1).(j).span = x3.span then loop (j - 1)
 662             else j + 1
 663           in
 664           loop (j3 - 1)
 665         in
 666         let j4 =
 667           let rec loop j =
 668             if j >= Array.length t.(i) then j - 1
 669             else if t.(i - 1).(j).span = x4.span then loop (j + 1)
 670             else j - 1
 671           in
 672           loop (j4 + 1)
 673         in
 674         loop (i - 1) j1 j2 j3 j4
 675   in
 676   loop i j1 j2 j3 j4
 677 ;;
 678
 679 let find_linked_children t i j1 j2 j3 j4 =
 680   let rec loop i j1 j2 j3 j4 =
 681     if i = Array.length t - 1 then j1, j2, j3, j4
 682     else
 683       let x1 = t.(i).(j1) in
 684       let x2 = t.(i).(j2) in
 685       let x3 = t.(i).(j3) in
 686       let x4 = t.(i).(j4) in
 687       let j1 =
 688         let rec loop j =
 689           if j < 0 then 0
 690           else if t.(i).(j).span = x1.span then loop (j - 1)
 691           else j + 1
 692         in
 693         loop (j1 - 1)
 694       in
 695       let j2 =
 696         let rec loop j =
 697           if j >= Array.length t.(i) then j - 1
 698           else if t.(i).(j).span = x2.span then loop (j + 1)
 699           else j - 1
 700         in
 701         loop (j2 + 1)
 702       in
 703       let j3 =
 704         let rec loop j =
 705           if j < 0 then 0
 706           else if t.(i).(j).span = x3.span then loop (j - 1)
 707           else j + 1
 708         in
 709         loop (j3 - 1)
 710       in
 711       let j4 =
 712         let rec loop j =
 713           if j >= Array.length t.(i) then j - 1
 714           else if t.(i).(j).span = x4.span then loop (j + 1)
 715           else j - 1
 716         in
 717         loop (j4 + 1)
 718       in
 719       loop (i + 1) j1 j2 j3 j4
 720   in
 721   loop i j1 j2 j3 j4
 722 ;;
 723
 724 let mirror_block t i1 i2 j1 j2 =
 725   for i = i1 to i2 do
 726     let line = t.(i) in
 727     let rec loop j1 j2 =
 728       if j1 >= j2 then ()
 729       else
 730         let v = line.(j1) in
 731         line.(j1) <- line.(j2); line.(j2) <- v; loop (j1 + 1) (j2 - 1)
 732     in
 733     loop j1 j2
 734   done
 735 ;;
 736
 737 let exch_blocks t i1 i2 j1 j2 j3 j4 =
 738   for i = i1 to i2 do
 739     let line = t.(i) in
 740     let saved = Array.copy line in
 741     for j = j1 to j2 do line.(j4 - j2 + j) <- saved.(j) done;
 742     for j = j3 to j4 do line.(j1 - j3 + j) <- saved.(j) done
 743   done
 744 ;;
 745
 746 let find_block_with_parents t i jj1 jj2 jj3 jj4 =
 747   let rec loop ii jj1 jj2 jj3 jj4 =
 748     let (nii, njj1, njj2, njj3, njj4) =
 749       find_same_parents t i jj1 jj2 jj3 jj4
 750     in
 751     if nii <> ii || njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 ||
 752        njj4 <> jj4 then
 753       let nii = min ii nii in
 754       let (jj1, jj2, jj3, jj4) =
 755         find_linked_children t nii njj1 njj2 njj3 njj4
 756       in
 757       if njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 || njj4 <> jj4 then
 758         loop nii jj1 jj2 jj3 jj4
 759       else nii, jj1, jj2, jj3, jj4
 760     else ii, jj1, jj2, jj3, jj4
 761   in
 762   loop i jj1 jj2 jj3 jj4
 763 ;;
 764
 765 let push_to_right d t i j1 j2 =
 766   let line = t.(i) in
 767   let rec loop j =
 768     if j = j2 then j - 1
 769     else
 770       let ini_jj1 =
 771         match line.(j - 1).elem with
 772           Nothing -> j - 1
 773         | x ->
 774             let rec same_value j =
 775               if j < 0 then 0
 776               else if line.(j).elem = x then same_value (j - 1)
 777               else j + 1
 778             in
 779             same_value (j - 2)
 780       in
 781       let jj1 = ini_jj1 in
 782       let jj2 = j - 1 in
 783       let jj3 = j in
 784       let jj4 =
 785         match line.(j).elem with
 786           Nothing -> j
 787         | x ->
 788             let rec same_value j =
 789               if j >= Array.length line then j - 1
 790               else if line.(j).elem = x then same_value (j + 1)
 791               else j - 1
 792             in
 793             same_value (j + 1)
 794       in
 795       let (ii, jj1, jj2, jj3, jj4) =
 796         find_block_with_parents t i jj1 jj2 jj3 jj4
 797       in
 798       if jj4 < j2 && jj2 < jj3 then
 799         begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj4 + 1) end
 800       else if jj4 < j2 && jj1 = ini_jj1 && jj2 <= jj4 then
 801         begin mirror_block t ii i jj1 jj4; loop (jj4 + 1) end
 802       else j - 1
 803   in
 804   loop (j1 + 1)
 805 ;;
 806
 807 let push_to_left d t i j1 j2 =
 808   let line = t.(i) in
 809   let rec loop j =
 810     if j = j1 then j + 1
 811     else
 812       let jj1 =
 813         match line.(j).elem with
 814           Nothing -> j
 815         | x ->
 816             let rec same_value j =
 817               if j < 0 then 0
 818               else if line.(j).elem = x then same_value (j - 1)
 819               else j + 1
 820             in
 821             same_value (j - 1)
 822       in
 823       let jj2 = j in
 824       let jj3 = j + 1 in
 825       let ini_jj4 =
 826         match line.(j + 1).elem with
 827           Nothing -> j + 1
 828         | x ->
 829             let rec same_value j =
 830               if j >= Array.length line then j - 1
 831               else if line.(j).elem = x then same_value (j + 1)
 832               else j - 1
 833             in
 834             same_value (j + 2)
 835       in
 836       let jj4 = ini_jj4 in
 837       let (ii, jj1, jj2, jj3, jj4) =
 838         find_block_with_parents t i jj1 jj2 jj3 jj4
 839       in
 840       if jj1 > j1 && jj2 < jj3 then
 841         begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj1 - 1) end
 842       else if jj1 > j1 && jj4 = ini_jj4 && jj3 >= jj1 then
 843         begin mirror_block t ii i jj1 jj4; loop (jj1 - 1) end
 844       else j + 1
 845   in
 846   loop (j2 - 1)
 847 ;;
 848
 849 let fill_gap d t i j1 j2 =
 850   let t1 =
 851     let t1 = Array.copy t.table in
 852     for i = 0 to Array.length t.table - 1 do
 853       t1.(i) <- Array.copy t.table.(i);
 854       for j = 0 to Array.length t1.(i) - 1 do
 855         t1.(i).(j) <- copy_data t.table.(i).(j)
 856       done
 857     done;
 858     t1
 859   in
 860   let j2 = push_to_left d t1 i j1 j2 in
 861   let j1 = push_to_right d t1 i j1 j2 in
 862   if j1 = j2 - 1 then
 863     let line = t1.(i - 1) in
 864     let x = line.(j1).span in
 865     let y = line.(j2).span in
 866     let rec loop y j =
 867       if j >= Array.length line then ()
 868       else if line.(j).span = y || t1.(i).(j).elem = t1.(i).(j - 1).elem then
 869         let y = line.(j).span in
 870         line.(j).span <- x;
 871         if i > 0 then t1.(i - 1).(j).span <- t1.(i - 1).(j - 1).span;
 872         loop y (j + 1)
 873     in
 874     loop y j2; Some ({table = t1}, true)
 875   else None
 876 ;;
 877
 878 let treat_gaps d t =
 879   let i = Array.length t.table - 1 in
 880   let rec loop t j =
 881     let line = t.table.(i) in
 882     if j = Array.length line then t
 883     else
 884       match line.(j).elem with
 885         Elem _ as y ->
 886           if y = line.(j - 1).elem then loop t (j + 1)
 887           else
 888             let rec loop1 t j1 =
 889               if j1 < 0 then loop t (j + 1)
 890               else if y = line.(j1).elem then
 891                 match fill_gap d t i j1 j with
 892                   Some (t, ok) -> if ok then loop t 2 else loop t (j + 1)
 893                 | None -> loop t (j + 1)
 894               else loop1 t (j1 - 1)
 895             in
 896             loop1 t (j - 2)
 897       | _ -> loop t (j + 1)
 898   in
 899   if Array.length t.table.(i) = 1 then t else loop t 2
 900 ;;
 901
 902 let group_span_last_row t =
 903   let row = t.table.(Array.length t.table - 1) in
 904   let rec loop i =
 905     if i >= Array.length row then ()
 906     else
 907       begin
 908         begin match row.(i).elem with
 909           Elem _ | Ghost _ as x ->
 910             if x = row.(i - 1).elem then row.(i).span <- row.(i - 1).span
 911         | _ -> ()
 912         end;
 913         loop (i + 1)
 914       end
 915   in
 916   loop 1
 917 ;;
 918
 919 let has_phony_children phony d t =
 920   let line = t.table.(Array.length t.table - 1) in
 921   let rec loop j =
 922     if j = Array.length line then false
 923     else
 924       match line.(j).elem with
 925         Elem x -> if phony d.dag.(int_of_idag x) then true else loop (j + 1)
 926       | _ -> loop (j + 1)
 927   in
 928   loop 0
 929 ;;
 930
 931 let tablify phony no_optim no_group d =
 932   let a = ancestors d in
 933   let r = group_by_common_children d a in
 934   let t = {table = [| Array.of_list r |]} in
 935   let rec loop t =
 936     let (t, new_row) = treat_new_row d t in
 937     if List.for_all (fun x -> x.elem = Nothing) new_row then t
 938     else
 939       let t = {table = Array.append t.table [| Array.of_list new_row |]} in
 940       let t =
 941         if no_group && not (has_phony_children phony d t) then t
 942         else
 943           let _ = if no_optim then () else equilibrate t in
 944           let _ = group_elem t in
 945           let _ = group_ghost t in
 946           let _ = group_children t in
 947           let _ = group_span_by_common_children d t in
 948           let t = if no_optim then t else treat_gaps d t in
 949           let _ = group_span_last_row t in t
 950       in
 951       loop t
 952   in
 953   loop t
 954 ;;
 955
 956 let fall d t =
 957   for i = 1 to Array.length t.table - 1 do
 958     let line = t.table.(i) in
 959     let rec loop j =
 960       if j = Array.length line then ()
 961       else
 962         match line.(j).elem with
 963           Ghost x ->
 964             let j2 =
 965               let rec loop j =
 966                 if j = Array.length line then j - 1
 967                 else
 968                   match line.(j).elem with
 969                     Ghost y when y = x -> loop (j + 1)
 970                   | _ -> j - 1
 971               in
 972               loop (j + 1)
 973             in
 974             let i1 =
 975               let rec loop i =
 976                 if i < 0 then i + 1
 977                 else
 978                   let line = t.table.(i) in
 979                   if (j = 0 || line.(j - 1).span <> line.(j).span) &&
 980                      (j2 = Array.length line - 1 ||
 981                       line.(j2 + 1).span <> line.(j2).span) then
 982                     loop (i - 1)
 983                   else i + 1
 984               in
 985               loop (i - 1)
 986             in
 987             let i1 =
 988               if i1 = i then i1
 989               else if i1 = 0 then i1
 990               else if t.table.(i1).(j).elem = Nothing then i1
 991               else i
 992             in
 993             if i1 < i then
 994               begin
 995                 for k = i downto i1 + 1 do
 996                   for j = j to j2 do
 997                     t.table.(k).(j).elem <- t.table.(k - 1).(j).elem;
 998                     if k < i then
 999                       t.table.(k).(j).span <- t.table.(k - 1).(j).span
1000                   done
1001                 done;
1002                 for l = j to j2 do
1003                   if i1 = 0 || t.table.(i1 - 1).(l).elem = Nothing then
1004                     t.table.(i1).(l).elem <- Nothing
1005                   else
1006                     t.table.(i1).(l) <-
1007                       if l = j ||
1008                          t.table.(i1 - 1).(l - 1).span <>
1009                            t.table.(i1 - 1).(l).span then
1010                         {elem = Ghost (new_ghost_id ());
1011                          span = new_span_id ()}
1012                       else copy_data t.table.(i1).(l - 1)
1013                 done
1014               end;
1015             loop (j2 + 1)
1016         | _ -> loop (j + 1)
1017     in
1018     loop 0
1019   done
1020 ;;
1021
1022 let fall2_cool_right t i1 i2 i3 j1 j2 =
1023   let span = t.table.(i2 - 1).(j1).span in
1024   for i = i2 - 1 downto 0 do
1025     for j = j1 to j2 - 1 do
1026       t.table.(i).(j) <-
1027         if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
1028         else {elem = Nothing; span = new_span_id ()}
1029     done
1030   done;
1031   for i = Array.length t.table - 1 downto 0 do
1032     for j = j2 to Array.length t.table.(i) - 1 do
1033       t.table.(i).(j) <-
1034         if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
1035         else {elem = Nothing; span = new_span_id ()}
1036     done
1037   done;
1038   let old_span = t.table.(i2 - 1).(j1).span in
1039   let rec loop j =
1040     if j = Array.length t.table.(i2 - 1) then ()
1041     else if t.table.(i2 - 1).(j).span = old_span then
1042       begin t.table.(i2 - 1).(j).span <- span; loop (j + 1) end
1043   in
1044   loop j1
1045 ;;
1046
1047 let fall2_cool_left t i1 i2 i3 j1 j2 =
1048   let span = t.table.(i2 - 1).(j2).span in
1049   for i = i2 - 1 downto 0 do
1050     for j = j1 + 1 to j2 do
1051       t.table.(i).(j) <-
1052         if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
1053         else {elem = Nothing; span = new_span_id ()}
1054     done
1055   done;
1056   for i = Array.length t.table - 1 downto 0 do
1057     for j = j1 downto 0 do
1058       t.table.(i).(j) <-
1059         if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
1060         else {elem = Nothing; span = new_span_id ()}
1061     done
1062   done;
1063   let old_span = t.table.(i2 - 1).(j2).span in
1064   let rec loop j =
1065     if j < 0 then ()
1066     else if t.table.(i2 - 1).(j).span = old_span then
1067       begin t.table.(i2 - 1).(j).span <- span; loop (j - 1) end
1068   in
1069   loop j2
1070 ;;
1071
1072 let do_fall2_right t i1 i2 j1 j2 =
1073   let i3 =
1074     let rec loop_i i =
1075       if i < 0 then 0
1076       else
1077         let rec loop_j j =
1078           if j = Array.length t.table.(i) then loop_i (i - 1)
1079           else
1080             match t.table.(i).(j).elem with
1081               Nothing -> loop_j (j + 1)
1082             | _ -> i + 1
1083         in
1084         loop_j j2
1085     in
1086     loop_i (Array.length t.table - 1)
1087   in
1088   let new_height = i3 + i2 - i1 in
1089   let t =
1090     if new_height > Array.length t.table then
1091       let rec loop cnt t =
1092         if cnt = 0 then t
1093         else
1094           let new_line =
1095             Array.init (Array.length t.table.(0))
1096               (fun i -> {elem = Nothing; span = new_span_id ()})
1097           in
1098           let t = {table = Array.append t.table [| new_line |]} in
1099           loop (cnt - 1) t
1100       in
1101       loop (new_height - Array.length t.table) t
1102     else t
1103   in
1104   fall2_cool_right t i1 i2 i3 j1 j2; t
1105 ;;
1106
1107 let do_fall2_left t i1 i2 j1 j2 =
1108   let i3 =
1109     let rec loop_i i =
1110       if i < 0 then 0
1111       else
1112         let rec loop_j j =
1113           if j < 0 then loop_i (i - 1)
1114           else
1115             match t.table.(i).(j).elem with
1116               Nothing -> loop_j (j - 1)
1117             | _ -> i + 1
1118         in
1119         loop_j j1
1120     in
1121     loop_i (Array.length t.table - 1)
1122   in
1123   let new_height = i3 + i2 - i1 in
1124   let t =
1125     if new_height > Array.length t.table then
1126       let rec loop cnt t =
1127         if cnt = 0 then t
1128         else
1129           let new_line =
1130             Array.init (Array.length t.table.(0))
1131               (fun i -> {elem = Nothing; span = new_span_id ()})
1132           in
1133           let t = {table = Array.append t.table [| new_line |]} in
1134           loop (cnt - 1) t
1135       in
1136       loop (new_height - Array.length t.table) t
1137     else t
1138   in
1139   fall2_cool_left t i1 i2 i3 j1 j2; t
1140 ;;
1141
1142 let do_shorten_too_long t i1 j1 j2 =
1143   for i = i1 to Array.length t.table - 2 do
1144     for j = j1 to j2 - 1 do t.table.(i).(j) <- t.table.(i + 1).(j) done
1145   done;
1146   let i = Array.length t.table - 1 in
1147   for j = j1 to j2 - 1 do
1148     t.table.(i).(j) <- {elem = Nothing; span = new_span_id ()}
1149   done;
1150   t
1151 ;;
1152
1153 let try_fall2_right t i j =
1154   match t.table.(i).(j).elem with
1155     Ghost _ ->
1156       let i1 =
1157         let rec loop i =
1158           if i < 0 then 0
1159           else
1160             match t.table.(i).(j).elem with
1161               Ghost _ -> loop (i - 1)
1162             | _ -> i + 1
1163         in
1164         loop (i - 1)
1165       in
1166       let separated1 =
1167         let rec loop i =
1168           if i < 0 then true
1169           else if
1170             j > 0 && t.table.(i).(j - 1).span = t.table.(i).(j).span then
1171             false
1172           else loop (i - 1)
1173         in
1174         loop (i1 - 1)
1175       in
1176       let j2 =
1177         let x = t.table.(i).(j).span in
1178         let rec loop j2 =
1179           if j2 = Array.length t.table.(i) then j2
1180           else
1181             match t.table.(i).(j2) with
1182               {elem = Ghost _; span = y} when y = x -> loop (j2 + 1)
1183             | _ -> j2
1184         in
1185         loop (j + 1)
1186       in
1187       let separated2 =
1188         let rec loop i =
1189           if i = Array.length t.table then true
1190           else if j2 = Array.length t.table.(i) then false
1191           else if t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then false
1192           else loop (i + 1)
1193         in
1194         loop (i + 1)
1195       in
1196       if not separated1 || not separated2 then None
1197       else Some (do_fall2_right t i1 (i + 1) j j2)
1198   | _ -> None
1199 ;;
1200
1201 let try_fall2_left t i j =
1202   match t.table.(i).(j).elem with
1203     Ghost _ ->
1204       let i1 =
1205         let rec loop i =
1206           if i < 0 then 0
1207           else
1208             match t.table.(i).(j).elem with
1209               Ghost _ -> loop (i - 1)
1210             | _ -> i + 1
1211         in
1212         loop (i - 1)
1213       in
1214       let separated1 =
1215         let rec loop i =
1216           if i < 0 then true
1217           else if
1218             j < Array.length t.table.(i) - 1 &&
1219             t.table.(i).(j).span = t.table.(i).(j + 1).span then
1220             false
1221           else loop (i - 1)
1222         in
1223         loop (i1 - 1)
1224       in
1225       let j1 =
1226         let x = t.table.(i).(j).span in
1227         let rec loop j1 =
1228           if j1 < 0 then j1
1229           else
1230             match t.table.(i).(j1) with
1231               {elem = Ghost _; span = y} when y = x -> loop (j1 - 1)
1232             | _ -> j1
1233         in
1234         loop (j - 1)
1235       in
1236       let separated2 =
1237         let rec loop i =
1238           if i = Array.length t.table then true
1239           else if j1 < 0 then false
1240           else if t.table.(i).(j1).span = t.table.(i).(j1 + 1).span then false
1241           else loop (i + 1)
1242         in
1243         loop (i + 1)
1244       in
1245       if not separated1 || not separated2 then None
1246       else Some (do_fall2_left t i1 (i + 1) j1 j)
1247   | _ -> None
1248 ;;
1249
1250 let try_shorten_too_long t i j =
1251   match t.table.(i).(j).elem with
1252     Ghost _ ->
1253       let j2 =
1254         let x = t.table.(i).(j).span in
1255         let rec loop j2 =
1256           if j2 = Array.length t.table.(i) then j2
1257           else
1258             match t.table.(i).(j2) with
1259               {elem = Ghost _; span = y} when y = x -> loop (j2 + 1)
1260             | _ -> j2
1261         in
1262         loop (j + 1)
1263       in
1264       let i1 =
1265         let rec loop i =
1266           if i = Array.length t.table then i
1267           else
1268             match t.table.(i).(j).elem with
1269               Elem _ -> loop (i + 1)
1270             | _ -> i
1271         in
1272         loop (i + 1)
1273       in
1274       let i2 =
1275         let rec loop i =
1276           if i = Array.length t.table then i
1277           else
1278             match t.table.(i).(j).elem with
1279               Nothing -> loop (i + 1)
1280             | _ -> i
1281         in
1282         loop i1
1283       in
1284       let separated_left =
1285         let rec loop i =
1286           if i = i2 then true
1287           else if
1288             j > 0 && t.table.(i).(j).span = t.table.(i).(j - 1).span then
1289             false
1290           else loop (i + 1)
1291         in
1292         loop i
1293       in
1294       let separated_right =
1295         let rec loop i =
1296           if i = i2 then true
1297           else if
1298             j2 < Array.length t.table.(i) &&
1299             t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then
1300             false
1301           else loop (i + 1)
1302         in
1303         loop i
1304       in
1305       if not separated_left || not separated_right then None
1306       else if i2 < Array.length t.table then None
1307       else Some (do_shorten_too_long t i j j2)
1308   | _ -> None
1309 ;;
1310
1311 let fall2_right t =
1312   let rec loop_i i t =
1313     if i <= 0 then t
1314     else
1315       let rec loop_j j t =
1316         if j < 0 then loop_i (i - 1) t
1317         else
1318           match try_fall2_right t i j with
1319             Some t -> loop_i (Array.length t.table - 1) t
1320           | None -> loop_j (j - 1) t
1321       in
1322       loop_j (Array.length t.table.(i) - 2) t
1323   in
1324   loop_i (Array.length t.table - 1) t
1325 ;;
1326
1327 let fall2_left t =
1328   let rec loop_i i t =
1329     if i <= 0 then t
1330     else
1331       let rec loop_j j t =
1332         if j >= Array.length t.table.(i) then loop_i (i - 1) t
1333         else
1334           match try_fall2_left t i j with
1335             Some t -> loop_i (Array.length t.table - 1) t
1336           | None -> loop_j (j + 1) t
1337       in
1338       loop_j 1 t
1339   in
1340   loop_i (Array.length t.table - 1) t
1341 ;;
1342
1343 let shorten_too_long t =
1344   let rec loop_i i t =
1345     if i <= 0 then t
1346     else
1347       let rec loop_j j t =
1348         if j >= Array.length t.table.(i) then loop_i (i - 1) t
1349         else
1350           match try_shorten_too_long t i j with
1351             Some t -> loop_i (Array.length t.table - 1) t
1352           | None -> loop_j (j + 1) t
1353       in
1354       loop_j 1 t
1355   in
1356   loop_i (Array.length t.table - 1) t
1357 ;;
1358
1359 (* top_adjust:
1360    deletes all empty rows that might have appeared on top of the table
1361    after the falls *)
1362
1363 let top_adjust t =
1364   let di =
1365     let rec loop i =
1366       if i = Array.length t.table then i
1367       else
1368         let rec loop_j j =
1369           if j = Array.length t.table.(i) then loop (i + 1)
1370           else if t.table.(i).(j).elem <> Nothing then i
1371           else loop_j (j + 1)
1372         in
1373         loop_j 0
1374     in
1375     loop 0
1376   in
1377   if di > 0 then
1378     begin
1379       for i = 0 to Array.length t.table - 1 - di do
1380         t.table.(i) <- t.table.(i + di)
1381       done;
1382       {table = Array.sub t.table 0 (Array.length t.table - di)}
1383     end
1384   else t
1385 ;;
1386
1387 (* bottom_adjust:
1388    deletes all empty rows that might have appeared on bottom of the table
1389    after the falls *)
1390
1391 let bottom_adjust t =
1392   let last_i =
1393     let rec loop i =
1394       if i < 0 then i
1395       else
1396         let rec loop_j j =
1397           if j = Array.length t.table.(i) then loop (i - 1)
1398           else if t.table.(i).(j).elem <> Nothing then i
1399           else loop_j (j + 1)
1400         in
1401         loop_j 0
1402     in
1403     loop (Array.length t.table - 1)
1404   in
1405   if last_i < Array.length t.table - 1 then
1406     {table = Array.sub t.table 0 (last_i + 1)}
1407   else t
1408 ;;
1409
1410 (* invert *)
1411
1412 let invert_dag d =
1413   let d = {dag = Array.copy d.dag} in
1414   for i = 0 to Array.length d.dag - 1 do
1415     let n = d.dag.(i) in
1416     d.dag.(i) <-
1417       {pare = List.map (fun x -> x) n.chil; valu = n.valu;
1418        chil = List.map (fun x -> x) n.pare}
1419   done;
1420   d
1421 ;;
1422
1423 let invert_table t =
1424   let t' = {table = Array.copy t.table} in
1425   let len = Array.length t.table in
1426   for i = 0 to len - 1 do
1427     t'.table.(i) <-
1428       Array.init (Array.length t.table.(0))
1429         (fun j ->
1430            let d = t.table.(len - 1 - i).(j) in
1431            {elem = d.elem; span = d.span});
1432     if i < len - 1 then
1433       for j = 0 to Array.length t'.table.(i) - 1 do
1434         t'.table.(i).(j).span <- t.table.(len - 2 - i).(j).span
1435       done
1436   done;
1437   t'
1438 ;;
1439
1440 (* main *)
1441
1442 let table_of_dag phony no_optim invert no_group d =
1443   let d = if invert then invert_dag d else d in
1444   let t = tablify phony no_optim no_group d in
1445   let t = if invert then invert_table t else t in
1446   let _ = fall () t in
1447   let t = fall2_right t in
1448   let t = fall2_left t in
1449   let t = shorten_too_long t in
1450   let t = top_adjust t in let t = bottom_adjust t in t
1451 ;;
1452
1453
1454 let version = "1.01";;
1455
1456 (* input dag *)
1457
1458 let strip_spaces str =
1459   let start =
1460     let rec loop i =
1461       if i == String.length str then i
1462       else
1463         match str.[i] with
1464           ' ' | '\013' | '\n' | '\t' -> loop (i + 1)
1465         | _ -> i
1466     in
1467     loop 0
1468   in
1469   let stop =
1470     let rec loop i =
1471       if i == -1 then i + 1
1472       else
1473         match str.[i] with
1474           ' ' | '\013' | '\n' | '\t' -> loop (i - 1)
1475         | _ -> i + 1
1476     in
1477     loop (String.length str - 1)
1478   in
1479   if start == 0 && stop == String.length str then str
1480   else if start > stop then ""
1481   else String.sub str start (stop - start)
1482 ;;
1483
1484 let rec get_line ic =
1485   try
1486     let line = input_line ic in
1487     if String.length line > 0 && line.[0] = '#' then get_line ic
1488     else Some (strip_spaces line)
1489   with
1490     End_of_file -> None
1491 ;;
1492
1493 let input_dag ic =
1494   let rec find cnt s =
1495     function
1496       n :: nl ->
1497         if n.valu = s then n, idag_of_int cnt else find (cnt - 1) s nl
1498     | [] -> raise Not_found
1499   in
1500   let add_node pl cl nl cnt =
1501     let cl = List.rev cl in
1502     let pl = List.rev pl in
1503     let (pl, pnl, nl, cnt) =
1504       List.fold_left
1505         (fun (pl, pnl, nl, cnt) p ->
1506            try
1507              let (n, p) = find (cnt - 1) p nl in p :: pl, n :: pnl, nl, cnt
1508            with
1509              Not_found ->
1510                let n = {pare = []; valu = p; chil = []} in
1511                let p = idag_of_int cnt in p :: pl, n :: pnl, n :: nl, cnt + 1)
1512         ([], [], nl, cnt) pl
1513     in
1514     let pl = List.rev pl in
1515     let (cl, nl, cnt) =
1516       List.fold_left
1517         (fun (cl, nl, cnt) c ->
1518            try
1519              let (n, c) = find (cnt - 1) c nl in
1520              n.pare <- n.pare @ pl; c :: cl, nl, cnt
1521            with
1522              Not_found ->
1523                let n = {pare = pl; valu = c; chil = []} in
1524                let c = idag_of_int cnt in c :: cl, n :: nl, cnt + 1)
1525         ([], nl, cnt) cl
1526     in
1527     let cl = List.rev cl in
1528     List.iter (fun p -> p.chil <- p.chil @ cl) pnl; nl, cnt
1529   in
1530   let rec input_parents nl pl cnt =
1531     function
1532       Some "" -> input_parents nl pl cnt (get_line ic)
1533     | Some line ->
1534         begin match line.[0] with
1535           'o' ->
1536             let p =
1537               strip_spaces (String.sub line 1 (String.length line - 1))
1538             in
1539             if p = "" then failwith line
1540             else input_parents nl (p :: pl) cnt (get_line ic)
1541         | '-' ->
1542             if pl = [] then failwith line
1543             else input_children nl pl [] cnt (Some line)
1544         | _ -> failwith line
1545         end
1546     | None -> if pl = [] then nl, cnt else failwith "end of file 1"
1547   and input_children nl pl cl cnt =
1548     function
1549       Some "" -> input_children nl pl cl cnt (get_line ic)
1550     | Some line ->
1551         begin match line.[0] with
1552           'o' ->
1553             if cl = [] then failwith line
1554             else
1555               let (nl, cnt) = add_node pl cl nl cnt in
1556               input_parents nl [] cnt (Some line)
1557         | '-' ->
1558             let c =
1559               strip_spaces (String.sub line 1 (String.length line - 1))
1560             in
1561             if c = "" then failwith line
1562             else input_children nl pl (c :: cl) cnt (get_line ic)
1563         | _ -> failwith line
1564         end
1565     | None ->
1566         if cl = [] then failwith "end of file 2" else add_node pl cl nl cnt
1567   in
1568   let (nl, _) = input_parents [] [] 0 (get_line ic) in
1569   {dag = Array.of_list (List.rev nl)}
1570 ;;
1571
1572 (* testing *)
1573
1574 let map_dag f d =
1575   let a =
1576     Array.map (fun d -> {pare = d.pare; valu = f d.valu; chil = d.chil}) d.dag
1577   in
1578   {dag = a}
1579 ;;
1580
1581 let tag_dag d =
1582   let c = ref 'A' in
1583   map_dag
1584     (fun v ->
1585        let v = !c in
1586        c :=
1587          if !c = 'Z' then 'a'
1588          else if !c = 'z' then '1'
1589          else Char.chr (Char.code !c + 1);
1590        String.make 1 v)
1591     d
1592 ;;
1593
1594 (* *)
1595
1596 let phony _ = false;;
1597 let indi_txt n = n.valu;;
1598
1599 let string_table border hts =
1600   let buf = Buffer.create 30 in
1601   Printf.bprintf buf "<center><table border=%d" border;
1602   Printf.bprintf buf " cellspacing=0 cellpadding=0>\n";
1603   for i = 0 to Array.length hts - 1 do
1604     Printf.bprintf buf  "<tr>\n";
1605     for j = 0 to Array.length hts.(i) - 1 do
1606       let (colspan, align, td) = hts.(i).(j) in
1607       Printf.bprintf buf "<td";
1608       if colspan = 1 && (td = TDstring "&nbsp;" || td = TDhr CenterA) then ()
1609       else Printf.bprintf buf " colspan=%d" colspan;
1610       begin match align, td with
1611         LeftA, TDhr LeftA -> Printf.bprintf buf " align=left"
1612       | LeftA, _ -> ()
1613       | CenterA, _ -> Printf.bprintf buf " align=center"
1614       | RightA, _ -> Printf.bprintf buf " align=right"
1615       end;
1616       Printf.bprintf buf ">";
1617       begin match td with
1618         TDstring s -> Printf.bprintf buf "%s" s
1619       | TDhr align ->
1620           Printf.bprintf buf "<hr noshade size=1";
1621           begin match align with
1622             LeftA -> Printf.bprintf buf " width=\"50%%\" align=left"
1623           | RightA -> Printf.bprintf buf " width=\"50%%\" align=right"
1624           | _ -> ()
1625           end;
1626           Printf.bprintf buf ">";
1627           ()
1628       end;
1629       Printf.bprintf buf "</td>\n";
1630       ()
1631     done
1632   done;
1633   Printf.bprintf buf "</table></center>\n";
1634   Buffer.contents buf
1635 ;;
1636
1637 let fname = ref "";;
1638 let invert = ref false;;
1639 let char = ref false;;
1640 let border = ref 0;;
1641 let no_optim = ref false;;
1642 let no_group = ref false;;
1643
1644 let html_of_dag d =
1645   let t = table_of_dag phony !no_optim !invert !no_group d in
1646   let hts = html_table_struct indi_txt phony d t in
1647   string_table !border hts
1648 ;;
1649
1650
1651 (********************************* Max's code **********************************)
1652 (** This function takes a list of classes and a list of class types
1653    and create the associate dag. *)
1654 let create_class_dag cl_list clt_list =
1655   let module M = Odoc_info.Class in
1656   (* the list of all the classes concerned *)
1657   let cl_list2 = List.map (fun c -> (c.M.cl_name, Some (M.Cl c))) cl_list in
1658   let clt_list2 = List.map (fun ct -> (ct.M.clt_name, Some (M.Cltype (ct, [])))) clt_list in
1659   let list = cl_list2 @ clt_list2 in
1660   let all_classes =
1661     let rec iter list2 =
1662       List.fold_left
1663         (fun acc -> fun (name, cct_opt) ->
1664           let l =
1665             match cct_opt with
1666               None -> []
1667             | Some (M.Cl c) ->
1668                 iter
1669                   (List.map
1670                      (fun inh ->(inh.M.ic_name, inh.M.ic_class))
1671                      (match c.M.cl_kind with
1672                        M.Class_structure (inher_l, _) ->
1673                          inher_l
1674                      | _ ->
1675                          []
1676                      )
1677                   )
1678             | Some (M.Cltype (ct, _)) ->
1679                 iter
1680                   (List.map
1681                      (fun inh ->(inh.M.ic_name, inh.M.ic_class))
1682                      (match ct.M.clt_kind with
1683                        M.Class_signature (inher_l, _) ->
1684                          inher_l
1685                      | _ ->
1686                          []
1687                      )
1688                   )
1689           in
1690           (name, cct_opt) :: (acc @ l)
1691         )
1692         []
1693         list2
1694     in
1695     iter list
1696   in
1697   let rec distinct acc = function
1698     [] ->
1699       acc
1700     |   (name, cct_opt) :: q ->
1701         if List.exists (fun (name2, _) -> name = name2) acc then
1702           distinct acc q
1703         else
1704           distinct ((name, cct_opt) :: acc) q
1705   in
1706   let distinct_classes = distinct [] all_classes in
1707   let liste_index =
1708     let rec f n = function
1709         [] -> []
1710       | (name, _) :: q -> (name, n) :: (f (n+1) q)
1711     in
1712     f 0 distinct_classes
1713   in
1714   let array1 = Array.of_list distinct_classes in
1715   (* create the dag array, filling parents and values *)
1716   let fmap (name, cct_opt) =
1717     { pare = List.map
1718         (fun inh -> List.assoc inh.M.ic_name liste_index )
1719         (match cct_opt with
1720           None -> []
1721         | Some (M.Cl c) ->
1722             (match c.M.cl_kind with
1723               M.Class_structure (inher_l, _) ->
1724                 inher_l
1725             | _ ->
1726                 []
1727             )
1728         | Some (M.Cltype (ct, _)) ->
1729             (match ct.M.clt_kind with
1730               M.Class_signature (inher_l, _) ->
1731                 inher_l
1732             | _ ->
1733                 []
1734             )
1735         );
1736       valu = (name, cct_opt) ;
1737       chil = []
1738     }
1739   in
1740   let dag = { dag = Array.map fmap array1 } in
1741   (* fill the children *)
1742   let fiter i node =
1743     let l = Array.to_list dag.dag in
1744     let l2 = List.map (fun n -> n.valu)
1745         (List.filter (fun n -> List.mem i n.pare) l)
1746     in
1747     node.chil <- List.map (fun (name,_) -> List.assoc name liste_index) l2
1748   in
1749   Array.iteri fiter dag.dag;
1750   dag