helm/www/lambdadelta/bin/xhtbl/pass2.ml

   1 module O = Options
   2 module T = Table
   3 module M = Matrix
   4 module F = Fold
   5
   6 type status = {
   7    ts: T.size;   (* current dimensions *)
   8    tm: M.matrix; (* current matrix *)
   9 }
  10
  11 let initial t m = {
  12    ts = {t.T.ts with T.ri = 0; T.ci = 0};
  13    tm = m;
  14 }
  15
  16 let resize b sts tts =
  17    if b then begin (* parent is a row *)
  18       if tts.T.rf < sts.T.rf && tts.T.ri = 0 then
  19          failwith "underful column";
  20       {tts with T.rf = sts.T.rf; T.cf = tts.T.cf + sts.T.ci * tts.T.ci}
  21    end else begin (* parent is a column *)
  22       if tts.T.cf < sts.T.cf && tts.T.ci = 0 then
  23          failwith "underful row";
  24       {tts with T.cf = sts.T.cf; T.rf = tts.T.rf + sts.T.ri * tts.T.ri}
  25    end
  26
  27 let fill b sts tts =
  28    if b then (* parent is a row *)
  29       {sts with T.ri =
  30          let rf, ri = sts.T.rf - tts.T.rf, tts.T.ri in
  31          if ri = 0 then 0 else
  32          if rf mod ri = 0 then rf / ri else
  33          failwith "fracted column"
  34       }
  35    else (* parent is a column *)
  36       {sts with T.ci =
  37          let cf, ci = sts.T.cf - tts.T.cf, tts.T.ci in
  38          if ci = 0 then 0 else
  39          if cf mod ci = 0 then cf / ci else
  40          failwith "fracted row"
  41       }
  42
  43 let place b sts tts =
  44    if b then (* parent is a row *)
  45       {sts with T.x = sts.T.x + tts.T.cf}
  46    else (* parent is a column *)
  47       {sts with T.y = sts.T.y + tts.T.rf}
  48
  49 let set_key st t = match t.T.te with
  50    | T.Key (T.Text sl) -> M.set_key st.tm t.T.ts.T.y t.T.ts.T.x sl
  51    | _                 -> ()
  52
  53 let set_attrs st t =
  54    let rec aux y x =
  55       if y >= t.T.ts.T.rf then () else
  56       if x >= t.T.ts.T.cf then aux (succ y) 0 else begin
  57          M.set_attrs st.tm (t.T.ts.T.y + y) (t.T.ts.T.x + x) t.T.tc t.T.tu t.T.tx t.T.tn;
  58          aux y (succ x)
  59       end
  60    in
  61    match t.T.te with
  62       | T.Key _ -> aux 0 0
  63       | _       -> ()
  64
  65 let set_borders st t =
  66    let rec aux_we y =
  67       if y >= t.T.ts.T.rf then () else begin
  68          M.set_west st.tm (t.T.ts.T.y + y) t.T.ts.T.x t.T.tb;
  69          if t.T.ts.T.cf > 0 then
  70             M.set_east st.tm (t.T.ts.T.y + y) (t.T.ts.T.x + pred t.T.ts.T.cf) t.T.tb;
  71          aux_we (succ y)
  72       end
  73    in
  74    let rec aux_ns x =
  75       if x >= t.T.ts.T.cf then () else begin
  76          M.set_north st.tm t.T.ts.T.y (t.T.ts.T.x + x) t.T.tb;
  77          if t.T.ts.T.rf > 0 then
  78             M.set_south st.tm (t.T.ts.T.y + pred t.T.ts.T.rf) (t.T.ts.T.x + x) t.T.tb;
  79          aux_ns (succ x)
  80       end
  81    in
  82    match t.T.te with
  83       | T.Line (true, _) -> aux_we 0; aux_ns 0
  84       | _                -> ()
  85
  86 let print st t =
  87    if !O.e2 then
  88       Printf.printf "#%u: (%u+%u, %u+%u) - (%u+%u, %u+%u)\n"
  89          t.T.ti
  90          t.T.ts.T.rf t.T.ts.T.ri
  91          t.T.ts.T.cf t.T.ts.T.ci
  92          st.ts.T.rf st.ts.T.ri
  93          st.ts.T.cf st.ts.T.ci
  94
  95 (****************************************************************************)
  96
  97 let open_table st t =
  98    print st t;
  99    let ts = match t.T.ts.T.p with
 100       | None   ->
 101          let ts = fill false st.ts t.T.ts in
 102          let ts = fill true ts t.T.ts in
 103          t.T.ts <- resize false st.ts t.T.ts;
 104          t.T.ts <- resize true st.ts t.T.ts;
 105          ts
 106       | Some b ->
 107          let ts = fill b st.ts t.T.ts in
 108          t.T.ts <- resize b st.ts t.T.ts;
 109          ts
 110    in
 111    t.T.ts <- {t.T.ts with T.ri = 0; T.ci = 0; T.x = st.ts.T.x; T.y = st.ts.T.y};
 112    let ts = {ts with T.rf = t.T.ts.T.rf; T.cf = t.T.ts.T.cf} in
 113    let st = {st with ts = ts} in
 114    print st t; st
 115
 116 let close_table st t =
 117    set_key st t; set_attrs st t; set_borders st t; st
 118
 119 let map_key st k = st
 120
 121 let open_line b st = st
 122
 123 let open_entry b st = st
 124
 125 let close_entry b st sst =
 126    let ts = place b st.ts sst.ts in
 127    {st with ts = ts}
 128
 129 let close_line b st = st
 130
 131 let cb = {
 132    F.open_table = open_table; F.close_table = close_table;
 133    F.open_line = open_line; F.close_line = close_line;
 134    F.open_entry = open_entry; F.close_entry = close_entry;
 135    F.map_key = map_key;
 136 }
 137
 138 let process t m =
 139    let _ = F.fold_table cb (initial t m) t in ()